Refactor
:my
=>
'code'
Codes
Refactorings
Popular
Best
Submit
Spam
Account
Logout
Login
JavaScript doesn't seem to be activated, expect things to be ugly and sloppy!
Learn How to Create Your Own Programming Language
createyourproglang.com
Recent
FILE HOSTS PREMIUM ACCOUNT
ALL FILE HOST PREMIUM ACCOUNTS
Zynga Slingo Trainer v5.12
iTunes Gift Card Generator V3.1 2012
Diablo 3 GOLD Coins FREE
Working PS3 Jailbreak 3.65 And 3.66
ExtaBit Premium Accounts and Cookies
Steam Wallet Hack - Money Adder & Hack v3
Empires & Allies Hack Cheat Trainer v5.4.1
Eve Onnline 60 Days Time Card Generator v2
Popular
XBOX POINTS GENERATOR - MICROSOFT POINTS GENERATOR v1.2012
11 may 2012 premium uploading accounts 100% working
Free Microsoft Points
Free Microsoft Points - Microsoft Points Generator - Xbox Live Codes 2012
Car Town Free Blue Points Hack
Free CarTown Blue Points Generator and CarTown Templates
Better way to get content via jQuery $.get()
Free Microsoft Points
Simple Days Purger
Sharecash Downloader Bypass Surveys New 05/2012
Pastable version of
Raytracer in haskell
<pre class='prettyprint' language='haskell'>import System.IO import Data.Word import Foreign import Data.Char main :: IO () main = do handle <- openBinaryFile "test.bmp" WriteMode putBin handle header print $ head rays putBin handle bitmap hClose handle type Vector = (Double, Double, Double) type Color = (Word8, Word8, Word8) type Ray = (Vector, Vector) type Sphere = (Vector, Double) type Light = Sphere type Plane = Sphere type Primitive = (Sphere, Color) type Scene = (Primitive, [Primitive], [Primitive]) parMap = map -- arg can't deal with this in anything other than characters. trying to write bytes hurts my head header :: [Word8] header = parMap (fromIntegral . ord) $ fileHeader ++ infoHeader where fileHeader = "BM\54\249\54\0\0\0\0\0\54\0\0\0" infoHeader = "\40\0\0\0\32\3\0\0\88\2\0\0\1\0\24\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" putBin x y = (mapM new y) >>= mapM ((flip (hPutBuf x)) 1) bitmap :: [Word8] bitmap = concat $ parMap unTuple3 colors unTuple3 :: Color -> [Word8] unTuple3 (a,b,c) = [a,b,c] camera :: Vector camera = (0.0, 0.0, -5.0) createRay :: Double -> Double -> Ray createRay y x = (camera, (normalizeVector ((x,y,0) `subtractVector` camera))) rayx :: [Double] rayx = [8.0,7.98..(-7.98)] rayy :: [Double] rayy = [6.0,5.98..(-5.98)] createRays :: [Double] -> [Ray] createRays [] = [] createRays xs = (parMap (createRay (head xs)) rayx) ++ (createRays (tail xs)) rays :: [Ray] rays = createRays rayy -- reverse because BMP is a fucked up format colors = parMap (findIntersection scene) $ reverse rays scene :: Scene scene = createScene plane spheres lights plane :: Primitive plane = (((0, (-0.39), 0), 4.4), (128,128,128)) spheres :: [Primitive] spheres = bigSphere : littleSphere : [] bigSphere :: Primitive bigSphere = (((1.0, (-0.8), 3.0), 0.5), (255,128,128)) littleSphere :: Primitive littleSphere = ((((-5.5), (-0.5), 7.0), 0.4), (128,255,128)) lights = light1 : light2 : [] light1 = (((0.0, 5.0, 5.0), 0.02), (128, 128, 255)) light2 = (((2.0, 5.0, 1.0), 0.02), (255, 128, 255)) createScene :: Primitive -> [Primitive] -> [Primitive] -> Scene createScene x y z = (x, y, z) colorFromRay r (distance, ((center, radius), color)) = color findIntersection :: Scene -> Ray -> Color findIntersection (plane, spheres, lights) r = colorFromRay r $ foldl (pickShortestDistance) (1000, ((camera, 0.1), (255,255,255))) $ [intersectPlane plane r] ++ (intersectSpheres (spheres ++ lights) r ) pickShortestDistance :: (Double, Primitive) -> (Double, Primitive) -> (Double, Primitive) pickShortestDistance (x, y) (a, b) = if x < a || (a < 0 && x > 0) then (x, y) else (a, b) intersectSpheres :: [Primitive] -> Ray -> [(Double, Primitive)] intersectSpheres [] _ = [] intersectSpheres spheres r = (intersectSphere (head spheres) r) : (intersectSpheres (tail spheres) r) intersectSphere :: Primitive -> Ray -> (Double, Primitive) intersectSphere ((center, radius), color) (origin, direction) = let destination = normalizeVector $ center `subtractVector` origin b = - ( destination `dotProduct` (normalizeVector direction)) c = (destination `dotProduct` destination) - (radius * radius) d = b * b - c in if d > 0 then ((-b) - (sqrt d), ((center, radius),color)) else (10000, ((center, radius),color)) intersectLight ((center, radius), color) (origin, direction) = let destination = normalizeVector $ center `subtractVector` origin b = - ( destination `dotProduct` (normalizeVector direction)) c = (destination `dotProduct` destination) - (radius * radius) d = b * b - c in if d > 0 then ((-b) - (sqrt d), ((center, radius),(255,255,255))) else (10000, ((center, radius),color)) intersectPlane :: ((Vector, Double), Color) -> Ray -> (Double, Primitive) intersectPlane ((normal, distance), color) (origin, direction) = let d = normal `dotProduct` (direction `subtractVector` origin) n = normal `dotProduct` (normal `subtractVector` origin) in if d > 0 then (n / d, ((normal, distance),color)) else (10000, ((normal, distance),color)) normalizeVector :: Vector -> Vector normalizeVector v = scaleVector (1 / lengthVector v) v scaleVector :: Double -> Vector -> Vector scaleVector a (x,y,z) = (x*a, y*a, z*a) lengthVector :: Vector -> Double lengthVector (x,y,z) = sqrt ( x^2 + y^2 + z^2) addVector :: Vector -> Vector -> Vector addVector (a,b,c) (x,y,z) = (a+x, b+y, z+c) subtractVector :: Vector -> Vector -> Vector subtractVector (a,b,c) (x,y,z) = (a-x, b-y, c-z) dotProduct :: Vector -> Vector -> Double dotProduct (a,b,c) (x,y,z) = a*x + b*y + c*z crossProduct :: Vector -> Vector -> Vector crossProduct (a,b,c) (x,y,z) = ((b * z - c*y), (c*x - a*z), (a*y - b*x))</pre> <a href="http://www.refactormycode.com/codes/473-raytracer-in-haskell-lisp-seems-to-be-the-closest-answer-eh" style="color:#fff" title="As seen on RefactorMyCode.com"><img alt="Small_logo" src="http://www.refactormycode.com/images/small_logo.gif" style="border:0" /></a>