Commit 165ff28b authored by Nicolas Lenz's avatar Nicolas Lenz
Browse files

Order and add raytracer

parent f141e2da
module Main (main) where
import ClassyPrelude
import Codec.Picture
import Codec.Picture.Types
baseImage :: PrimMonad m => m (MutableImage (PrimState m) PixelRGB8)
baseImage = createMutableImage 500 500 (PixelRGB8 255 255 255)
pixelBlack :: PixelRGB8
pixelBlack = PixelRGB8 0 0 0
writePoints :: PrimMonad m => [Point] -> MutableImage (PrimState m) PixelRGB8 -> m ()
writePoints [] _ = return ()
writePoints ((Point x y):ps) image = writePixel image (truncate x) (truncate y) pixelBlack >> writePoints ps image
image :: PrimMonad m => m (Image PixelRGB8)
image = do
img <- baseImage
writePoints (bezierSample 10000 testCurve) img
freezeImage img
data Point = Point {pointX :: Double, pointY :: Double} deriving (Eq)
instance Show Point where
show Point{..} = "(" ++ show pointX ++ "," ++ show pointY ++ ")"
data Curve = Curve
{ curveStart :: Point
, curveStartControl :: Point
, curveEndControl :: Point
, curveEnd :: Point}
testCurve :: Curve
testCurve = Curve (Point 10 10) (Point 100 0) (Point 600 800) (Point 200 300)
pointScale :: Double -> Point -> Point
pointScale s Point{..} = Point (s * pointX) (s * pointY)
pointAdd :: Point -> Point -> Point
pointAdd p q = Point (pointX p + pointX q) (pointY p + pointY q)
trim :: Double -> Double
trim x
| x < 0 = 0
| x > 1 = 1
| otherwise = x
affine :: Double -> Point -> Point -> Point
affine t p q = ((1 - trim t) `pointScale` p) `pointAdd` (trim t `pointScale` q)
bezier :: Curve -> Double -> Point
bezier (Curve b00 b01 b02 b03) t = affine t b20 b21 where
b10 = affine t b00 b01
b11 = affine t b01 b02
b12 = affine t b02 b03
b20 = affine t b10 b11
b21 = affine t b11 b12
bezierSample :: Int -> Curve -> [Point]
bezierSample n c@Curve{..} = bezierSampleHelp <$> [0..n] where
bezierSampleHelp :: Int -> Point
bezierSampleHelp i
| i == 0 = curveStart
| i == n = curveEnd
| otherwise = bezier c (1 / (fromIntegral n) * (fromIntegral i))
main :: IO ()
main = do
img <- image
writePng "test.png" img
putStrLn "Image written"
name: experiments
dependencies:
- base
- base
- classy-prelude
default-extensions:
- NoImplicitPrelude
- OverloadedStrings
- LambdaCase
- RecordWildCards
executables:
pi:
main: Main.hs
source-dirs: pi
main: Main.hs
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
bezier:
source-dirs: bezier
main: Main.hs
dependencies:
- JuicyPixels
- vector
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
raytrace:
source-dirs: raytrace
main: Main.hs
dependencies:
- JuicyPixels
ghc-options:
- -threaded
- -rtsopts
......
module Main where
import ClassyPrelude
main :: IO ()
main = print $ Main.pi 1000000000
......
module Main where
import ClassyPrelude hiding (intersect)
import Codec.Picture hiding (imageHeight, imageWidth)
import Codec.Picture.Types hiding (imageHeight, imageWidth)
import Vector
data Ray = Ray
{ rayOrigin :: Vector3
, rayDirection :: Vector3
}
rayPoint :: Ray -> Double -> Vector3
rayPoint Ray{..} t = rayOrigin + scale t (normalize rayDirection)
data Object
= Sphere
{ sphereCenter :: Vector3
, sphereRadius :: Double
}
{-| Plane
{ planeCenter :: Vector3
, planeNormal :: Vector3}-}
newtype Scene = Scene {sceneObjects :: [Object]}
data Camera = Camera
{ cameraPosition :: Vector3
, cameraFocus :: Vector3
, cameraUp :: Vector3
, cameraFovy :: Double
, cameraWidth :: Word
, cameraHeight :: Word
}
intersect :: Ray -> Object -> Bool
intersect Ray{..} Sphere{..} = d >= 0.0 where
oc = rayOrigin - sphereCenter
a = dot rayDirection rayDirection
b = 2 * dot rayDirection oc
c = dot oc oc - sphereRadius * sphereRadius
d = b^2 - 4 * a * c
scene :: Scene
scene = Scene [{-Plane (Vector3 0 0 0) (Vector3 0 1 0), -} Sphere (Vector3 0 1 0) 0.5]
camera :: Camera
camera = Camera (Vector3 22 22 0) (Vector3 0 1 0) (Vector3 0 1 0) (0.8 * pi) 500 300
imageHeight, imageWidth :: Camera -> Double
imageHeight Camera{..} = 2 * (distance cameraPosition cameraFocus) * tan(0.5 * cameraFovy / 180 * pi)
imageWidth camera@Camera{..} = (fromIntegral cameraWidth) / (fromIntegral cameraHeight) * imageHeight camera
imageXAxis, imageYAxis, imageLowerLeft :: Camera -> Vector3
imageXAxis camera@Camera{..} = scale (imageWidth camera / fromIntegral cameraWidth) $ normalize (cross (cameraFocus - cameraPosition) cameraUp)
imageYAxis camera@Camera{..} = scale (imageHeight camera / fromIntegral cameraHeight) $ normalize (cross (imageXAxis camera) (cameraFocus - cameraPosition))
imageLowerLeft camera@Camera{..} = cameraFocus - scale (0.5 * fromIntegral cameraWidth) (imageXAxis camera) - scale (0.5 * fromIntegral cameraHeight) (imageYAxis camera)
-- | Generate a primary ray for a pixel in a given camera.
primaryRay :: Camera -> Double -> Double -> Ray
primaryRay camera@Camera{..} x y = Ray cameraPosition (imageLowerLeft camera + scale x (imageXAxis camera) + scale y (imageYAxis camera) - cameraPosition)
pixelBlack :: PixelRGB8
pixelBlack = PixelRGB8 0 0 0
pixelWhite :: PixelRGB8
pixelWhite = PixelRGB8 255 255 255
image :: Image PixelRGB8
image = generateImage f 500 300 where
f :: Int -> Int -> PixelRGB8
f x y
| or $ map (intersect $ primaryRay camera (fromIntegral x) (fromIntegral y)) (sceneObjects scene) = pixelBlack
| otherwise = pixelWhite
main :: IO ()
main = do
writePng "test.png" image
putStrLn "Image written"
module Vector where
import ClassyPrelude
data Vector3 = Vector3 Double Double Double
instance Num Vector3 where
(Vector3 x1 y1 z1) + (Vector3 x2 y2 z2) = Vector3 (x1 + x2) (y1 + y2) (z1 + z2)
(Vector3 x1 y1 z1) - (Vector3 x2 y2 z2) = Vector3 (x1 - x2) (y1 - y2) (z1 - z2)
(Vector3 x1 y1 z1) * (Vector3 x2 y2 z2) = Vector3 (x1 * x2) (y1 * y2) (z1 * z2)
abs (Vector3 x y z) = Vector3 (abs x) (abs y) (abs z)
signum (Vector3 x y z) = Vector3 (signum x) (signum y) (signum z)
fromInteger n = Vector3 (fromInteger n) (fromInteger n) (fromInteger n)
dot :: Vector3 -> Vector3 -> Double
dot (Vector3 x1 y1 z1) (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2
cross :: Vector3 -> Vector3 -> Vector3
cross (Vector3 x1 y1 z1) (Vector3 x2 y2 z2) = Vector3 (y1 * z2 - z1 * y2) (z1 * x2 - x1 * z2) (x1 * y2 - y1 * x2)
-- 1y * 2z - 1z * 2y, 1z * 2x - 1x * 2z, 1x * 2y - 1y * 2x
scale :: Double -> Vector3 -> Vector3
scale s (Vector3 x y z) = Vector3 (s * x) (s * y) (s * z)
norm :: Vector3 -> Double
norm vec = sqrt(dot vec vec)
distance :: Vector3 -> Vector3 -> Double
distance vec1 vec2 = norm (vec1 - vec2)
normalize :: Vector3 -> Vector3
normalize vec@(Vector3 x y z)
| n /= 0.0 = Vector3 (x / n) (y / n) (z / n)
| otherwise = vec
where n = norm vec
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment