Skip to content
Browse files

Adds a RayTracer.

One can now export raytraced images of 3D objects.
  • Loading branch information...
1 parent 57222ac commit 3ddcee5118f3518dec243d669bb05296b774a4ee @colah colah committed Sep 24, 2012
View
2 Graphics/Implicit.hs
@@ -36,6 +36,7 @@ module Graphics.Implicit(
writeSCAD2,
writeSCAD3,
writeGCodeHacklabLaser,
+ writePNG,
runOpenscad,
implicit,
SymbolicObj2,
@@ -59,4 +60,5 @@ writeSCAD2 = Export.writeSCAD2 :: ℝ -> FilePath -> SymbolicObj2 -> IO ()
writeSCAD3 = Export.writeSCAD3 ::-> FilePath -> SymbolicObj3 -> IO ()
writeTHREEJS = Export.writeTHREEJS ::-> FilePath -> SymbolicObj3 -> IO ()
writeGCodeHacklabLaser = Export.writeGCodeHacklabLaser ::-> FilePath -> SymbolicObj2 -> IO ()
+writePNG = Export.writePNG ::-> FilePath -> SymbolicObj3 -> IO ()
View
21 Graphics/Implicit/Export.hs
@@ -15,15 +15,18 @@ import qualified Data.ByteString.Lazy as LBS
import Graphics.Implicit.Export.Definitions
-- instances of DiscreteApproxable...
-import Graphics.Implicit.Export.SymbolicObj2
-import Graphics.Implicit.Export.SymbolicObj3
+import Graphics.Implicit.Export.SymbolicObj2 ()
+import Graphics.Implicit.Export.SymbolicObj3 ()
+import Graphics.Implicit.Export.RayTrace ()
-- File formats
import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats
import qualified Graphics.Implicit.Export.TriangleMeshFormats as TriangleMeshFormats
import qualified Graphics.Implicit.Export.NormedTriangleMeshFormats as NormedTriangleMeshFormats
import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats
+import qualified Codec.Picture as ImageFormatCodecs
+
-- Write an object in a given formet...
writeObject :: (DiscreteAproxable obj aprox) =>
@@ -35,6 +38,19 @@ writeObject :: (DiscreteAproxable obj aprox) =>
writeObject res format filename obj = writeFile filename $ formatObject res format obj
+writeObject' :: (DiscreteAproxable obj aprox) =>
+ ℝ -- ^ Resolution
+ -> (FilePath -> aprox -> IO ()) -- ^ File Format writer
+ -> FilePath -- ^ File Name
+ -> obj -- ^ Object to render
+ -> IO () -- ^ Writing Action!
+
+writeObject' res formatWriter filename obj =
+ let
+ aprox = discreteAprox res obj
+ in
+ formatWriter filename aprox
+
formatObject :: (DiscreteAproxable obj aprox) =>
-- ^ Resolution
-> (aprox -> Text) -- ^ File Format (Function that formats)
@@ -57,6 +73,7 @@ writeGCodeHacklabLaser res = writeObject res PolylineFormats.hacklabLaserGCode
writeSCAD3 res filename obj = writeFile filename $ SymbolicFormats.scad3 res obj
writeSCAD2 res filename obj = writeFile filename $ SymbolicFormats.scad2 res obj
+writePNG res = writeObject' res ImageFormatCodecs.savePngImage
{-
renderRaw :: ℝ3 -> ℝ3 -> ℝ -> String -> Obj3 -> IO()
View
191 Graphics/Implicit/Export/RayTrace.hs
@@ -0,0 +1,191 @@
+
+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}
+
+module Graphics.Implicit.Export.RayTrace where
+
+import Prelude hiding ((+),(-),(*),(/))
+import qualified Prelude as P
+import Graphics.Implicit.ObjectUtil
+import Graphics.Implicit.Definitions
+import Graphics.Implicit.SaneOperators
+import Graphics.Implicit.Export.Definitions
+import Codec.Picture
+import Control.Monad
+
+import Debug.Trace
+
+-- Definitions
+
+data Camera = Camera333
+data Ray = Ray33
+data Light = Light3
+data Scene = Scene Obj3 Color [Light] Color
+
+type Color = PixelRGB8
+color r g b = PixelRGB8 r g b
+dynamicImage = ImageRGB8
+
+-- Math
+
+d a b = norm (b-a)
+
+instance MultiplicativeColor Color where
+ s * (PixelRGB8 a b c) = color (s `mult` a) (s `mult` b) (s `mult` c)
+ where
+ bound = max 0 . min 255
+ mult a b = fromIntegral . round . bound $ a * (fromIntegral b :: ℝ)
+
+instance Multiplicative ColorColor where
+ a * b = b * a
+
+average :: [Color] -> Color
+average l =
+ let
+ (rs, gs, bs) = unzip3 $ map
+ (\(PixelRGB8 r g b) -> (fromIntegral r, fromIntegral g, fromIntegral b))
+ l :: ([ℝ], [ℝ], [ℝ])
+ n = fromIntegral $ length l ::
+ (r, g, b) = (sum rs/n, sum gs/n, sum bs/n)
+ in PixelRGB8
+ (fromIntegral . round $ r) (fromIntegral . round $ g) (fromIntegral . round $ b)
+
+-- Ray Utilities
+
+cameraRay :: Camera -> ℝ2 -> Ray
+cameraRay (Camera p vx vy f) (x,y) =
+ let
+ v = vx vy
+ p' = p + f*v + x*vx + y*vy
+ n = normalized (p' - p)
+ in
+ Ray p' n
+
+rayFromTo :: ℝ3 -> ℝ3 -> Ray
+rayFromTo p1 p2 = Ray p1 (normalized $ p2 - p1)
+
+rayBounds :: Ray -> (ℝ3, ℝ3) -> ℝ2
+rayBounds ray box =
+ let
+ Ray (cPx, cPy, cPz) cameraV@(cVx, cVy, cVz) = ray
+ ((x1,y1,z1),(x2,y2,z2)) = box
+ xbounds = [(x1 - cPx)/cVx, (x2-cPx)/cVx]
+ ybounds = [(y1-cPy)/cVy, (y2-cPy)/cVy]
+ zbounds = [(z1-cPz)/cVz, (z2-cPz)/cVz]
+ lower = maximum [minimum xbounds, minimum ybounds, minimum zbounds]
+ upper = minimum [maximum xbounds, maximum ybounds, maximum zbounds]
+ in
+ (lower, upper)
+
+-- Intersection
+
+
+intersection :: Ray -> ((ℝ,ℝ), ℝ) ->-> Obj3 -> Maybe ℝ3
+intersection r@(Ray p v) ((a, aval),b) res obj =
+ let
+ step = if aval/(4::ℝ) < res then res/(10 :: ℝ) else res
+ a' = a + step
+ a'val = obj (p + a'*v)
+ in if a'val < 0
+ then
+ let a'' = refine (a,a') (\s -> obj (p+s*v))
+ in Just (p + a''*v)
+ else if a' < b
+ then intersection r ((a',a'val), b) res obj
+ else Nothing
+
+refine :: ℝ2 -> (ℝ -> ℝ) ->
+refine (a, b) obj =
+ let
+ (aval, bval) = (obj a, obj b)
+ in if bval < aval
+ then refine' 10 (a, b) (aval, bval) obj
+ else refine' 10 (b, a) (aval, bval) obj
+
+refine' :: Int -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) ->
+refine' 0 (a, b) _ _ = a
+refine' n (a, b) (aval, bval) obj =
+ let
+ mid = (a+b)/(2::ℝ)
+ midval = obj mid
+ in
+ if midval == 0
+ then mid
+ else if midval < 0
+ then refine' (pred n) (a, mid) (aval, midval) obj
+ else refine' (pred n) (mid, b) (midval, bval) obj
+
+intersects a b c d = case intersection a b c d of
+ Nothing -> False
+ Just _ -> True
+
+-- Trace
+
+traceRay :: Ray ->-> (ℝ3, ℝ3) -> Scene -> Color
+traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultColor) =
+ let
+ (a,b) = rayBounds ray box
+ in case intersection ray ((a, obj (cameraP + a*cameraV)), b) step obj of
+ Just p -> objColor * (sum $ [0.1] ++ do
+ Light lightPos lightIntensity <- lights
+ let
+ ray'@(Ray _ v) = rayFromTo p lightPos
+ v' = normalized v
+ guard . not $ intersects ray' ((0, obj p),20) step obj
+ let
+ pval = obj p
+ step = 0.1 ::
+ dirDeriv :: ℝ3 ->
+ dirDeriv v = (obj (p + step*v) - pval)/step
+ deriv = (dirDeriv (1,0,0), dirDeriv (0,1,0), dirDeriv (0,0,1))
+ normal = normalized $ deriv
+ unitV = normalized $ v'
+ proj a b = (ab)*b
+ dist = d p lightPos
+ illumination = (max 0 (normal unitV)) * lightIntensity * ((350 :: ℝ)/dist^2)
+ rV =
+ let
+ normalComponent = proj v' normal
+ parComponent = v' - normalComponent
+ in
+ normalComponent - parComponent
+ return $ illumination + (4.5::ℝ)*lightIntensity * ((200 :: ℝ)/dist^2)*(abs $ rV cameraV)
+ )
+ Nothing -> defaultColor
+
+instance DiscreteAproxable SymbolicObj3 DynamicImage where
+ discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)
+ where
+ (w,h) = (200, 200) ::2
+ obj = getImplicit3 symbObj
+ box@((x1,y1,z1), (x2,y2,z2)) = getBox3 symbObj
+ av :: ℝ ->->
+ av a b = (a+b)/(2::ℝ)
+ avY = av y1 y2
+ avZ = av z1 z2
+ deviation = maximum [abs $ y1 - avY, abs $ y2 - avY, abs $ z1 - avZ, abs $ z2 - avZ]
+ camera = Camera (x1-deviation*(2.2::ℝ), avY, avZ) (0, -1, 0) (0,0, -1) 1.0
+ lights = [Light (x1-deviation*(1.5::ℝ), y1 - (0.4::ℝ)*(y2-y1), avZ) 2.5]
+ scene = Scene obj (PixelRGB8 200 200 210) lights (PixelRGB8 255 255 255 )
+ pixelRenderer :: Int -> Int -> Color
+ pixelRenderer a b = renderScreen
+ ((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ))
+ renderScreen :: ℝ ->-> Color
+ renderScreen a b =
+ let
+ ray = cameraRay camera (a,b)
+ in
+ average $ [
+ traceRay
+ (cameraRay camera ((a,b) + (( 0.25::ℝ)/w, ( 0.25::ℝ)/h)))
+ 2 box scene{-,
+ traceRay
+ (cameraRay camera ((a,b) + ((-0.25::ℝ)/w, ( 0.25::ℝ)/h)))
+ 0.5 box scene,
+ traceRay
+ (cameraRay camera ((a,b) + (( 0.25::ℝ)/w,-( 0.25::ℝ)/h)))
+ 0.5 box scene,
+ traceRay
+ (cameraRay camera ((a,b) + ((-0.25::ℝ)/w,-( 0.25::ℝ)/h)))
+ 0.5 box scene-}
+ ]
+
View
2 Graphics/Implicit/Export/Render.hs
@@ -185,7 +185,7 @@ getMesh (x1, y1, z1) (x2, y2, z2) res obj =
]| segZ' <- segsZ | segZT <- tail segsZ
| segY' <- segsY
| segX' <- segsX
- ] `using` (parListChunk (nx*ny*(max 1 $ div nz 32)) rdeepseq)
+ ]
in mergedSquareTris $ concat $ concat $ concat sqTris -- (5) merge squares, etc
View
7 extopenscad.hs
@@ -8,7 +8,7 @@
-- Let's be explicit about what we're getting from where :)
import System.Environment (getArgs)
import System.IO (openFile, IOMode (ReadMode), hGetContents, hClose)
-import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writeTHREEJS)
+import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writeTHREEJS, writePNG)
import Graphics.Implicit.ExtOpenScad.Definitions (OpenscadObj (ONum))
import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
import Graphics.Implicit.Definitions (xmlErrorOn, errorMessage)
@@ -97,11 +97,14 @@ executeAndExportSpecifiedTargetType content targetname formatname = case runOpen
putStrLn $ "Rendering 2D object to " ++ targetname
writeGCodeHacklabLaser res targetname x
("scad", (_, x:xs, _)) -> do
- putStrLn $ "Rendering 3D object to " ++ targetname
+ putStrLn $ "Rendering 2D object to " ++ targetname
writeSCAD2 res targetname x
("stl", (_, _, x:xs)) -> do
putStrLn $ "Rendering 3D object to " ++ targetname
writeBinSTL res targetname x
+ ("png", (_, _, x:xs)) -> do
+ putStrLn $ "Raytracing 3D object to " ++ targetname
+ writePNG res targetname x
("scad", (_, _, x:xs)) -> do
putStrLn $ "Rendering 3D object to " ++ targetname
writeSCAD3 res targetname x
View
1 implicit.cabal
@@ -84,6 +84,7 @@ Library
Graphics.Implicit.Export.MarchingSquaresFill
Graphics.Implicit.Export.SymbolicObj2
Graphics.Implicit.Export.SymbolicObj3
+ Graphics.Implicit.Export.RayTrace
Graphics.Implicit.Export.PolylineFormats
Graphics.Implicit.Export.TriangleMeshFormats
Graphics.Implicit.Export.NormedTriangleMeshFormats

0 comments on commit 3ddcee5

Please sign in to comment.
Something went wrong with that request. Please try again.