├── Setup.hs ├── ChangeLog.md ├── test └── Spec.hs ├── images ├── diel01.png ├── earth.png ├── focus.png ├── light.png ├── metal.png ├── smoke.png ├── sphere.png ├── checker.png ├── cornell.png ├── diffuse.png ├── gradient.png ├── multiple.png ├── spectral.png ├── 05-surface.png ├── antialias.png ├── fuzzmetal.png ├── motionblur.png ├── oneweekend.png ├── cornellFinal.png ├── oneweekendfinal.png ├── final-oneweekend-diffuse.png └── final-oneweekend-metallic.png ├── bin └── rt-haskell.out ├── src ├── Spectral │ ├── SampledWave.hs │ ├── Wave.hs │ ├── SpectrumUtils.hs │ ├── SampledDistribution.hs │ └── SampledSpectrum.hs ├── Lib.hs ├── Color │ ├── Colorable.hs │ ├── ColorIO.hs │ ├── Pixel.hs │ └── ColorInterface.hs ├── Texture │ ├── Texture.hs │ ├── Spectral.hs │ ├── TextureObj.hs │ ├── Checker.hs │ ├── SolidColor.hs │ └── Image.hs ├── Pdf │ ├── Pdf.hs │ ├── HittablePdf.hs │ ├── PdfObj.hs │ ├── CosinePdf.hs │ └── MixturePdf.hs ├── Hittable │ ├── Hittable.hs │ ├── HittableObj.hs │ ├── FlipFace.hs │ ├── Aabb.hs │ ├── HitRecord.hs │ ├── Translatable.hs │ ├── HittableList.hs │ ├── ConstantMedium.hs │ ├── Sphere.hs │ ├── MovingSphere.hs │ ├── Rotatable.hs │ └── Bvh.hs ├── Math3D │ ├── Ray.hs │ ├── CommonOps.hs │ ├── EulerAngles.hs │ ├── Onb.hs │ ├── Quaternion.hs │ ├── Transform.hs │ └── Matrix.hs ├── Utility │ ├── BaseEnum.hs │ ├── HelperTypes.hs │ └── Utils.hs ├── Material │ ├── ScatterRecord.hs │ ├── Material.hs │ └── Scatter.hs ├── Scene │ ├── Scene.hs │ ├── CheckerScene.hs │ ├── ImageScene.hs │ ├── PerlinSphere.hs │ ├── DiffuseSphere.hs │ ├── PerlinLight.hs │ ├── CornellBox.hs │ ├── SpectralScene.hs │ ├── CornellSphere.hs │ ├── CornellSmoke.hs │ ├── CornellImage.hs │ ├── RandomOneWeekendFinal.hs │ └── NextWeekFinal.hs ├── Scenes.hs ├── Random.hs ├── Instance │ └── Box.hs └── Camera.hs ├── .gitignore ├── stack.yaml.lock ├── LICENSE ├── package.yaml ├── stack.yaml ├── rt-haskell.cabal ├── app └── Main.hs └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for rt-haskell 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /images/diel01.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/diel01.png -------------------------------------------------------------------------------- /images/earth.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/earth.png -------------------------------------------------------------------------------- /images/focus.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/focus.png -------------------------------------------------------------------------------- /images/light.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/light.png -------------------------------------------------------------------------------- /images/metal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/metal.png -------------------------------------------------------------------------------- /images/smoke.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/smoke.png -------------------------------------------------------------------------------- /images/sphere.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/sphere.png -------------------------------------------------------------------------------- /bin/rt-haskell.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/bin/rt-haskell.out -------------------------------------------------------------------------------- /images/checker.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/checker.png -------------------------------------------------------------------------------- /images/cornell.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/cornell.png -------------------------------------------------------------------------------- /images/diffuse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/diffuse.png -------------------------------------------------------------------------------- /images/gradient.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/gradient.png -------------------------------------------------------------------------------- /images/multiple.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/multiple.png -------------------------------------------------------------------------------- /images/spectral.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/spectral.png -------------------------------------------------------------------------------- /images/05-surface.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/05-surface.png -------------------------------------------------------------------------------- /images/antialias.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/antialias.png -------------------------------------------------------------------------------- /images/fuzzmetal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/fuzzmetal.png -------------------------------------------------------------------------------- /images/motionblur.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/motionblur.png -------------------------------------------------------------------------------- /images/oneweekend.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/oneweekend.png -------------------------------------------------------------------------------- /src/Spectral/SampledWave.hs: -------------------------------------------------------------------------------- 1 | -- sampled wave 2 | module Spectral.SampledWave where 3 | 4 | 5 | -------------------------------------------------------------------------------- /images/cornellFinal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/cornellFinal.png -------------------------------------------------------------------------------- /images/oneweekendfinal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/oneweekendfinal.png -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /images/final-oneweekend-diffuse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/final-oneweekend-diffuse.png -------------------------------------------------------------------------------- /images/final-oneweekend-metallic.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/D-K-E/rt-haskell/master/images/final-oneweekend-metallic.png -------------------------------------------------------------------------------- /src/Color/Colorable.hs: -------------------------------------------------------------------------------- 1 | -- colorable type 2 | module Color.Colorable where 3 | 4 | import Math3D.Vector 5 | 6 | -- 7 | class Colorable a where 8 | toXYZ :: a -> Vector 9 | toRGB :: a -> Vector 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | dist 4 | dist-* 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.hie 9 | *.chi 10 | *.chs.h 11 | *.dyn_o 12 | *.dyn_hi 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | *.eventlog 21 | .stack-work/ 22 | cabal.project.local 23 | cabal.project.local~ 24 | .HTF/ 25 | .ghc.environment.* 26 | -------------------------------------------------------------------------------- /src/Texture/Texture.hs: -------------------------------------------------------------------------------- 1 | -- module texture 2 | module Texture.Texture where 3 | 4 | import Math3D.Vector 5 | import Color.ColorInterface 6 | 7 | -- base types and enums 8 | import Utility.BaseEnum 9 | 10 | class Texture a where 11 | -- object -> u -> v -> hit point -> wave length -> Color information 12 | color :: a -> Double -> Double -> Vector -> WaveVal -> ColorRecord 13 | -------------------------------------------------------------------------------- /src/Pdf/Pdf.hs: -------------------------------------------------------------------------------- 1 | -- pdf handling code 2 | module Pdf.Pdf where 3 | 4 | -- math 5 | import Math3D.Vector 6 | import Math3D.Onb 7 | 8 | -- random 9 | import Random 10 | import System.Random 11 | 12 | class Pdf a where 13 | -- obtain pdf sampling value 14 | pvalue :: RandomGen g => a -> g -> Vector -> RandomResult Double g 15 | -- generate direction 16 | generate :: RandomGen g => a -> g -> RandomResult Vector g 17 | -------------------------------------------------------------------------------- /src/Texture/Spectral.hs: -------------------------------------------------------------------------------- 1 | -- spectral texture type: SampledSpectrum that supports texture calls 2 | module Texture.Spectral where 3 | 4 | import Spectral.SampledSpectrum 5 | import Spectral.SampledDistribution 6 | 7 | import Texture.Texture 8 | 9 | import Color.ColorInterface 10 | 11 | data SpectralTexture = SpectT SampledSpectrum deriving (Eq, Show) 12 | 13 | instance Texture SpectralTexture where 14 | color (SpectT s) _ _ _ w = 15 | let p = evaluateWave w $! sampled s 16 | in ColorRec {model = ColorSpec (spectrumType s, (w, p))} 17 | -------------------------------------------------------------------------------- /src/Texture/TextureObj.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- module grouping texture adts 4 | module Texture.TextureObj where 5 | 6 | import Math3D.Vector 7 | 8 | -- texture 9 | import Texture.SolidColor 10 | import Texture.Checker 11 | import Texture.Noise 12 | import Texture.Texture 13 | import Texture.Image 14 | import Texture.Spectral 15 | 16 | data TextureObj where 17 | TextureCons :: Texture a => a -> TextureObj 18 | 19 | instance Texture TextureObj where 20 | color b hu hv hp w = 21 | case b of 22 | (TextureCons a) -> color a hu hv hp w 23 | -------------------------------------------------------------------------------- /src/Hittable/Hittable.hs: -------------------------------------------------------------------------------- 1 | -- module for hittable type 2 | module Hittable.Hittable where 3 | 4 | -- math 5 | import Math3D.Ray 6 | import Math3D.Vector 7 | 8 | import System.Random 9 | import Random 10 | 11 | -- hittable 12 | import Hittable.HitRecord 13 | import Hittable.Aabb 14 | 15 | class Hittable a where 16 | hit :: RandomGen g => a -> g -> Ray -> Double -> Double -> HitRecord -> (HitRecord, Bool, g) 17 | boundingBox :: a -> Double -> Double -> Aabb -> (Aabb, Bool) 18 | 19 | pdf_value :: RandomGen g => a -> g -> Vector -> Vector -> RandomResult Double g 20 | hrandom :: RandomGen g => a -> g -> Vector -> RandomResult Vector g 21 | -------------------------------------------------------------------------------- /src/Pdf/HittablePdf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- hittable pdf 4 | module Pdf.HittablePdf where 5 | 6 | import Pdf.Pdf 7 | 8 | -- math 9 | import Math3D.Vector 10 | 11 | -- utility 12 | import Utility.Utils 13 | 14 | -- hittable 15 | import Hittable.Hittable 16 | 17 | data HittablePdf where 18 | HitPdf :: Hittable a => a -> Vector -> HittablePdf 19 | 20 | instance Pdf HittablePdf where 21 | pvalue hpdf gen dir = 22 | case hpdf of 23 | (HitPdf a orig) -> pdf_value a gen orig dir 24 | 25 | generate hpdf g = 26 | case hpdf of 27 | (HitPdf a orig) -> hrandom a g orig 28 | -------------------------------------------------------------------------------- /src/Texture/Checker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | -- Checkered texture 4 | module Texture.Checker where 5 | 6 | import Math3D.Vector 7 | import Texture.Texture 8 | 9 | data Checker where 10 | CheckT :: forall a b. (Eq a, Eq b, Texture a, Texture b) => a -> b -> Checker 11 | 12 | 13 | instance Texture Checker where 14 | color (CheckT a b) hu hv hp w = 15 | let xv = vget hp 0 16 | yv = vget hp 1 17 | zv = vget hp 2 18 | sinval = sin xv * sin yv * sin zv 19 | cval = if sinval < 0 20 | then color a hu hv hp w 21 | else color b hu hv hp w 22 | in cval 23 | -------------------------------------------------------------------------------- /src/Pdf/PdfObj.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- type that implements pdf 4 | module Pdf.PdfObj where 5 | 6 | import Pdf.Pdf 7 | import Math3D.Vector 8 | import Random 9 | 10 | data NoPdf = NPdf {npdfVal :: Bool} 11 | 12 | data PdfObj where 13 | PdfCons :: Pdf a => a -> PdfObj 14 | 15 | instance Pdf PdfObj where 16 | 17 | pvalue a g v = 18 | case a of 19 | PdfCons b -> pvalue b g v 20 | 21 | generate a g = 22 | case a of 23 | PdfCons b -> generate b g 24 | 25 | instance Pdf NoPdf where 26 | pvalue _ g _ = RandResult (0.0, g) 27 | generate _ g = randomVec (0.0, 1.0) g 28 | 29 | emptyPdfObj :: PdfObj 30 | emptyPdfObj = PdfCons $ NPdf {npdfVal = False} 31 | -------------------------------------------------------------------------------- /src/Math3D/Ray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- ray module 3 | module Math3D.Ray where 4 | 5 | import Math3D.Vector 6 | import Math3D.CommonOps 7 | 8 | import Utility.BaseEnum 9 | 10 | data Ray = Rd { 11 | origin :: Vector, 12 | direction :: Vector, 13 | rtime :: Double, 14 | wavelength :: WaveVal 15 | } deriving (Show, Eq) 16 | 17 | zeroRay :: Int -> Ray 18 | zeroRay !nbDims = Rd {origin = zeroV nbDims, 19 | direction = zeroV nbDims, 20 | rtime = 0.0, 21 | wavelength = 0.0 22 | } 23 | zeroRay3 :: Ray 24 | zeroRay3 = zeroRay 3 25 | 26 | at :: Ray -> Double -> Vector 27 | at !a !c = add (origin a) (multiplyS (direction a) c) 28 | -------------------------------------------------------------------------------- /src/Spectral/Wave.hs: -------------------------------------------------------------------------------- 1 | module Spectral.Wave where 2 | 3 | import Math3D.Vector 4 | 5 | -- planar wave as described by E. Hecht, Optics, 2017, p. 121-122; fig. 4.45 6 | 7 | data PlaneWave = PWave { 8 | -- represented with E_0 in the equation 9 | amplitude :: Double, 10 | 11 | -- represented with r in the equation 4.12, and fig. 4.45 12 | position :: Vector, 13 | 14 | -- represented with k in the equation 4.12, and fig. 4.45 15 | direction :: Vector, 16 | 17 | -- represented with w in the equation 4.12 18 | angularFrequency :: Double, 19 | 20 | -- represented with t in the equation 4.12 21 | time :: Double 22 | } deriving (Eq, Show) 23 | 24 | 25 | evalPlaneWave :: PlaneWave -> Double 26 | -- e0 * cos (k \dot r - w * t) = E 27 | evalPlaneWave pw = 28 | let e0 = amplitude pw 29 | r = position pw 30 | k = direction pw 31 | w = angularFrequency pw 32 | t = time pw 33 | in e0 * (cos ((dot k r) - (w * t))) 34 | -------------------------------------------------------------------------------- /src/Texture/SolidColor.hs: -------------------------------------------------------------------------------- 1 | -- module solid color 2 | module Texture.SolidColor where 3 | 4 | -- math3d 5 | import Math3D.Vector 6 | 7 | -- color 8 | import Color.ColorInterface 9 | 10 | -- spectral 11 | import Spectral.SampledSpectrum 12 | -- texture 13 | import Texture.Texture 14 | 15 | data SolidColor = SolidP Double 16 | | SolidD Double Double Double 17 | 18 | instance Texture SolidColor where 19 | color (SolidP a) _ _ _ w = ColorRec { model = ColorSpec (ILLUMINANT, (w, a))} 20 | 21 | color (SolidD a b c) _ _ _ _ = ColorRec {model = ColorRGB $! fromList2Vec a [b, c]} 22 | 23 | instance Eq SolidColor where 24 | (SolidP v) == (SolidD a b c) = False 25 | (SolidP a) == (SolidP b ) = a == b 26 | (SolidD a b c) == (SolidP v) = False 27 | (SolidD a b c) == (SolidD d e f) = (a == d) && (b == e) && (c == f) 28 | 29 | instance Show SolidColor where 30 | show (SolidP a) = "Solid Color Power: " ++ show a 31 | show (SolidD a b c) = "Solid Color Vector: " ++ (show $ fromList2Vec a [b, c]) 32 | -------------------------------------------------------------------------------- /src/Pdf/CosinePdf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- cosine pdf type 4 | module Pdf.CosinePdf where 5 | 6 | import Pdf.Pdf 7 | 8 | -- math 9 | import Math3D.Onb 10 | import Math3D.Vector 11 | 12 | -- utility 13 | import Utility.Utils 14 | import Random 15 | 16 | data CosinePdf where 17 | CosPdf :: OrthoNormalBase -> CosinePdf 18 | CosNormalPdf :: Vector -> CosinePdf 19 | 20 | instance Pdf CosinePdf where 21 | pvalue !a gen !dir = 22 | case a of 23 | CosPdf onb -> 24 | let cval = dot (toUnit dir) (wBasis onb) 25 | rval = if cval <= 0.0 26 | then 0.0 27 | else cval / m_pi 28 | in RandResult (rval, gen) 29 | CosNormalPdf v -> pvalue (CosPdf $ fromW2Onb v) gen dir 30 | 31 | generate !a g = 32 | case a of 33 | CosPdf onb -> let res = randomCosineDir g 34 | in rfmap (localVec onb) res 35 | 36 | CosNormalPdf v -> generate (CosPdf $! fromW2Onb v) g 37 | -------------------------------------------------------------------------------- /src/Utility/BaseEnum.hs: -------------------------------------------------------------------------------- 1 | -- basic enumeration types 2 | module Utility.BaseEnum where 3 | 4 | 5 | -- spectral value types 6 | type WaveVal = Float 7 | type PowerVal = Double 8 | 9 | 10 | data NaNBehavior = ALL_NAN 11 | | ANY_NAN 12 | | REPLACE_NAN Double 13 | | DONT_CARE_NAN 14 | deriving(Eq, Show) 15 | 16 | 17 | -- cie trichromatic 18 | data CIETrichroma = CIE_X 19 | | CIE_Y 20 | | CIE_Z 21 | deriving(Eq, Show) 22 | 23 | -- rgb to spectral flags 24 | data Rgb2Spect = REFL_WHITE 25 | | REFL_CYAN 26 | | REFL_MAGENTA 27 | | REFL_YELLOW 28 | | REFL_RED 29 | | REFL_GREEN 30 | | REFL_BLUE 31 | | ILLUM_WHITE 32 | | ILLUM_CYAN 33 | | ILLUM_MAGENTA 34 | | ILLUM_YELLOW 35 | | ILLUM_RED 36 | | ILLUM_GREEN 37 | | ILLUM_BLUE 38 | deriving (Show, Eq) 39 | 40 | -- 41 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: random-1.1@sha256:7b67624fd76ddf97c206de0801dc7e888097e9d572974be9b9ea6551d76965df,1777 9 | pantry-tree: 10 | size: 637 11 | sha256: 14a1b01728c5584e87c9fa00746a66e28ffd89dd2c0eabd334c8463953496e1b 12 | original: 13 | hackage: random-1.1 14 | - completed: 15 | hackage: stb-image-0.2.1@sha256:784700aa0a317f94215c0c992bbb61fa0a58284d040a7ed646b6b4c2c16273e7,1432 16 | pantry-tree: 17 | size: 389 18 | sha256: afb20707ca5e29199b658fcde2337a9d12187400f6dea7308d3819d093d9a571 19 | original: 20 | hackage: stb-image-0.2.1 21 | - completed: 22 | hackage: bitmap-0.0.2@sha256:4b0cd4e7d24ae2cdc23e76aefd45fcffa77c8bec922ecb600832e951cb507992,1622 23 | pantry-tree: 24 | size: 876 25 | sha256: b1d4eb48f3817438454a74f32bf5c684a554b35d6f68b6dcffe63c02ac12f238 26 | original: 27 | hackage: bitmap-0.0.2 28 | snapshots: [] 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Viva Lambda and D-K-E 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice an this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE.d 22 | -------------------------------------------------------------------------------- /src/Math3D/CommonOps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- common operations for multi valued numbers such as vectors matrix etc 3 | module Math3D.CommonOps where 4 | 5 | import Debug.Trace 6 | 7 | class Eq a => BinaryOps a where 8 | elementwiseOp :: String -> (Double -> Double -> Double) -> a -> a -> a 9 | elementwiseScalarOp :: String -> (Double -> Double) -> a -> a 10 | add :: a -> a -> a 11 | add !a !b = elementwiseOp "add" (+) a b 12 | subtract :: a -> a -> a 13 | subtract !a !b = elementwiseOp "subtract" (-) a b 14 | multiply :: a -> a -> a 15 | multiply !a !b = elementwiseOp "multiply" (*) a b 16 | divide :: a -> a -> a 17 | addS :: a -> Double -> a 18 | addS !a !s = let f d = d + s in elementwiseScalarOp "add" f a 19 | subtractS :: a -> Double -> a 20 | subtractS !a !s = let f d = d - s in elementwiseScalarOp "subtract" f a 21 | multiplyS :: a -> Double -> a 22 | multiplyS !a !s = let f d = d * s in elementwiseScalarOp "multiply" f a 23 | divideS :: a -> Double -> a 24 | divideS !a !s = if s == 0.0 25 | then traceStack "ZeroDivisionError :: performing zero division" a 26 | else let f d = d / s in elementwiseScalarOp "divide" f a 27 | -------------------------------------------------------------------------------- /src/Material/ScatterRecord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- scatter record 4 | module Material.ScatterRecord where 5 | 6 | -- math 7 | import Math3D.Ray 8 | import Math3D.Vector 9 | 10 | -- color related 11 | import Color.ColorInterface 12 | 13 | -- pdf handling 14 | import Pdf.PdfObj 15 | import Pdf.Pdf 16 | 17 | data ScatterRecord where 18 | ScatterRec :: Ray -> Bool -> ColorRecord -> PdfObj -> ScatterRecord 19 | 20 | 21 | mkSRecord :: Pdf a => Ray -> Bool -> ColorRecord -> a -> ScatterRecord 22 | mkSRecord r b v a = ScatterRec r b v (PdfCons a) 23 | 24 | emptySRecord :: PdfObj -> Int -> ScatterRecord 25 | emptySRecord pobj size = mkSRecord (zeroRay size) False emptyRGBRecord pobj 26 | 27 | emptySRec :: PdfObj -> ScatterRecord 28 | emptySRec pobj = emptySRecord pobj 3 29 | 30 | specularRaySR :: ScatterRecord -> Ray 31 | specularRaySR a = case a of 32 | (ScatterRec r _ _ _) -> r 33 | 34 | isSpecularSR :: ScatterRecord -> Bool 35 | isSpecularSR a = case a of 36 | (ScatterRec _ b _ _) -> b 37 | 38 | attenuationSR :: ScatterRecord -> ColorRecord 39 | attenuationSR a = case a of 40 | (ScatterRec _ _ b _) -> b 41 | 42 | pdfPtrSR :: ScatterRecord -> PdfObj 43 | pdfPtrSR a = case a of 44 | (ScatterRec _ _ _ b) -> b 45 | -------------------------------------------------------------------------------- /src/Pdf/MixturePdf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- mixture pdf object 4 | module Pdf.MixturePdf where 5 | 6 | import Pdf.Pdf 7 | 8 | -- math3d 9 | import Math3D.Vector 10 | 11 | -- utility etc 12 | import Utility.Utils 13 | import Utility.HelperTypes 14 | 15 | -- 16 | import Random 17 | 18 | -- other 19 | import GHC.Float 20 | 21 | -- mix n number of pdfs 22 | data MixturePdf where 23 | MixPdf :: Pdf a => NonEmptyList a -> MixturePdf 24 | 25 | instance Pdf MixturePdf where 26 | pvalue !mpdf gen !dir = 27 | case mpdf of 28 | (MixPdf mxs) -> let weight = 1.0 / (int2Double $ lengthNL mxs) 29 | objs = nl2List mxs 30 | fn acc pobj = let RandResult (pval, g) = acc 31 | res = pvalue pobj g dir 32 | res2 = rfmap (+ pval) res 33 | in rfmap (* weight) res2 34 | in foldl fn (RandResult (0.0, gen)) objs 35 | 36 | generate !mpdf g = 37 | case mpdf of 38 | (MixPdf mxs) -> 39 | let upper = lengthNL $! mxs 40 | RandResult (index, g2) = randomInt g (0, upper) 41 | in generate (getNL mxs index) g2 42 | -------------------------------------------------------------------------------- /src/Hittable/HittableObj.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- hittable object module 4 | module Hittable.HittableObj where 5 | 6 | import Hittable.Hittable 7 | import Hittable.Sphere 8 | import Hittable.MovingSphere 9 | import Hittable.AaRect 10 | import Hittable.Rotatable 11 | import Hittable.Translatable 12 | 13 | -- 14 | import Math3D.Vector 15 | 16 | -- 17 | import Instance.Box 18 | 19 | data HittableObj where 20 | HittableCons :: (Eq a, Show a, Hittable a) => a -> HittableObj 21 | 22 | instance Eq HittableObj where 23 | a == b = 24 | case a of 25 | HittableCons a1 -> 26 | case b of 27 | HittableCons a1 -> a1 == a1 28 | 29 | instance Show HittableObj where 30 | show a = 31 | case a of 32 | HittableCons a1 -> show a1 33 | 34 | 35 | 36 | instance Hittable HittableObj where 37 | {-# INLINE hit #-} 38 | hit hobj g !ry !tmin !tmax !hrec = 39 | case hobj of 40 | (HittableCons a) -> hit a g ry tmin tmax hrec 41 | 42 | boundingBox hobj time0 time1 ab = 43 | case hobj of 44 | (HittableCons s) -> boundingBox s time0 time1 ab 45 | 46 | pdf_value hobj g o v = 47 | case hobj of 48 | (HittableCons s) -> pdf_value s g o v 49 | 50 | hrandom hobj g v = 51 | case hobj of 52 | (HittableCons s) -> hrandom s g v 53 | -------------------------------------------------------------------------------- /src/Scene/Scene.hs: -------------------------------------------------------------------------------- 1 | -- scene module 2 | module Scene.Scene where 3 | 4 | import Math3D.Vector 5 | 6 | import Color.Pixel 7 | import Hittable.HittableList 8 | 9 | import GHC.Float 10 | 11 | data Scene = SceneVals { 12 | img_width :: Int, 13 | img_height :: Int, 14 | aspect_ratio :: Double, 15 | nb_samples :: Int, 16 | bounce_depth :: Int, 17 | cam_look_from :: Vector, 18 | cam_look_to :: Vector, 19 | cam_vup :: Vector, 20 | cam_vfov :: Double, 21 | cam_aperture :: Double, 22 | cam_focus_distance :: Double, 23 | scene_obj :: HittableList, 24 | sample_obj :: HittableList, 25 | back_ground :: PixelSpectrum 26 | } 27 | 28 | -- default values 29 | imageWidth :: Int 30 | imageWidth = 320 31 | 32 | aspectRatio :: Double 33 | aspectRatio = 16.0 / 9.0 34 | 35 | imageHeight :: Int 36 | imageHeight = double2Int $! (int2Double imageWidth) / aspectRatio 37 | 38 | getImgHeight :: Int -> Double -> Int 39 | getImgHeight w a = double2Int $! (int2Double w) / a 40 | 41 | nbSamples :: Int 42 | nbSamples = 50 43 | 44 | bounceDepth :: Int 45 | bounceDepth = 20 46 | 47 | camLookFrom :: Vector 48 | camLookFrom = fromList2Vec 13.0 [2.0, 3.0] 49 | 50 | camLookTo :: Vector 51 | camLookTo = fromList2Vec 0.0 [0.0, 0.0] 52 | 53 | camVFov :: Double 54 | camVFov = 20.0 55 | 56 | camVUp :: Vector 57 | camVUp = fromList2Vec 0.0 [1.0, 0.0] 58 | 59 | camFocDistance :: Double 60 | camFocDistance = 10.0 61 | -------------------------------------------------------------------------------- /src/Hittable/FlipFace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | -- rotatable 5 | module Hittable.FlipFace where 6 | 7 | -- hittable 8 | import Hittable.Hittable 9 | import Hittable.Aabb 10 | import Hittable.HitRecord 11 | 12 | -- math 13 | import Math3D.Vector 14 | import Math3D.CommonOps 15 | 16 | -- thirdparty 17 | import Prelude hiding(subtract) 18 | 19 | data FlipFace where 20 | FlipHittable :: (Show a, Hittable a, Eq a) => a -> String -> FlipFace 21 | 22 | instance Show FlipFace where 23 | show (FlipHittable a _) = let msg1 = "" 24 | 25 | instance Eq FlipFace where 26 | (FlipHittable _ a) == (FlipHittable _ b) = a == b 27 | 28 | instance Hittable FlipFace where 29 | hit (FlipHittable a _) g !ry !tmin !tmax !hrec = 30 | let (srec, isHit, g1) = hit a g ry tmin tmax hrec 31 | in if not isHit 32 | then (srec, isHit, g1) 33 | else (HRec { 34 | point = point srec, 35 | pnormal = pnormal srec, 36 | hdist = hdist srec, 37 | hUV_u = hUV_u srec, 38 | hUV_v = hUV_v srec, 39 | matPtr = matPtr srec, 40 | isFront = not $! isFront srec 41 | }, True, g1) 42 | 43 | boundingBox (FlipHittable a _) tmn tmx ab = boundingBox a tmn tmx ab 44 | pdf_value a g orig v = 45 | case a of 46 | FlipHittable b _ -> pdf_value b g orig v 47 | hrandom a g orig = 48 | case a of 49 | FlipHittable b _ -> hrandom b g orig 50 | -------------------------------------------------------------------------------- /src/Hittable/Aabb.hs: -------------------------------------------------------------------------------- 1 | -- Aabb axis aligned bounding box 2 | module Hittable.Aabb where 3 | 4 | import Math3D.Vector 5 | import Math3D.Ray 6 | import Prelude hiding (subtract) 7 | 8 | data Aabb = AaBbox {aabbMin :: Vector, aabbMax :: Vector} deriving (Eq, Show) 9 | 10 | zeroAabb :: Int -> Aabb 11 | zeroAabb nbDims = AaBbox {aabbMin = zeroV nbDims, aabbMax = zeroV nbDims} 12 | 13 | zeroAabb3 :: Aabb 14 | zeroAabb3 = zeroAabb 3 15 | 16 | compHitAabb :: Int -> Aabb -> Ray -> Double -> Double -> Bool 17 | compHitAabb i (AaBbox {aabbMin = a, aabbMax = b}) ray tmin tmax = 18 | let invD = 1.0 / (vget (direction ray) i) 19 | t0 = ((vget a i) - (vget (origin ray) i)) * invD 20 | t1 = ((vget b i) - (vget (origin ray) i)) * invD 21 | tfirst = if invD < 0.0 then t1 else t0 22 | tsecond = if tfirst == t1 then t0 else t1 23 | t_min = if tfirst > tmin then tfirst else tmin 24 | t_max = if tsecond < tmax then tsecond else tmax 25 | in not (t_max <= t_min) 26 | 27 | aabbHit :: Aabb -> Ray -> Double -> Double -> Bool 28 | aabbHit ab ray t_min t_max = 29 | let AaBbox {aabbMin = a, aabbMax = b} = ab 30 | lena = vsize a 31 | isHit = foldl1 (&&) [compHitAabb i ab ray t_min t_max | i <- [0..(lena - 1)]] 32 | in isHit 33 | 34 | -- surrounding box 35 | ssBox :: Aabb -> Aabb -> Aabb 36 | ssBox (AaBbox {aabbMin = a, aabbMax = b}) 37 | (AaBbox {aabbMin = c, aabbMax = d}) = 38 | let f el = vec2List el 39 | (mi:mn) = zipWith min (f a) (f c) 40 | (ma:mx) = zipWith max (f b) (f d) 41 | in AaBbox {aabbMin = fromList2Vec mi mn, aabbMax = fromList2Vec ma mx} 42 | -------------------------------------------------------------------------------- /src/Hittable/HitRecord.hs: -------------------------------------------------------------------------------- 1 | -- hit record module 2 | module Hittable.HitRecord where 3 | 4 | import Math3D.Vector 5 | import Math3D.CommonOps 6 | import Math3D.Ray 7 | import Material.Material 8 | 9 | 10 | data HitRecord = HRec {point :: Vector, pnormal :: Vector, hdist :: Double, 11 | hUV_u :: Double, hUV_v :: Double, 12 | matPtr :: Material, isFront :: Bool} 13 | 14 | emptyRecord :: Int -> HitRecord 15 | emptyRecord nbDims = HRec {point = zeroV nbDims, 16 | pnormal = zeroV nbDims, 17 | hdist = 0.0, 18 | hUV_u = 0.0, 19 | hUV_v = 0.0, 20 | matPtr = NoMat, 21 | isFront = False} 22 | 23 | emptyRec :: HitRecord 24 | emptyRec = emptyRecord 3 25 | 26 | setFaceNormal :: HitRecord -> Ray -> Vector -> HitRecord 27 | setFaceNormal HRec {point = p, 28 | pnormal = pv, 29 | hdist = t, 30 | hUV_u = u, 31 | hUV_v = v, 32 | matPtr = m, 33 | isFront = _} Rd {origin = ro, direction = rd} ov = 34 | let ffaceCond = (dot rd ov ) < 0.0 35 | in if ffaceCond 36 | then HRec {point = p, pnormal = ov, hUV_u = u, 37 | hUV_v = v, hdist = t, matPtr = m, 38 | isFront = ffaceCond} 39 | else HRec {point = p, 40 | pnormal = multiplyS ov (-1.0), 41 | hdist = t, 42 | matPtr = m, 43 | hUV_u = u, 44 | hUV_v = v, 45 | isFront = ffaceCond 46 | } 47 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: rt-haskell 2 | version: 0.1.0.0 3 | github: "githubuser/rt-haskell" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2021 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.8.2.0 24 | - containers >= 0.5.6.2 25 | - random >= 1.1 26 | - time >= 1.5.0 27 | - stb-image >= 0.2.1 28 | - bitmap >= 0.0.2 29 | 30 | library: 31 | source-dirs: src 32 | 33 | executables: 34 | rt-haskell.out: 35 | main: Main.hs 36 | source-dirs: app 37 | ghc-options: 38 | - -threaded 39 | - -rtsopts 40 | - -with-rtsopts=-N 41 | #- -fllvm -optlo-O3 -optl-ffast-math 42 | #- -fexcess-precision 43 | #- -funfolding-use-threshold1000 44 | - -Wall 45 | #- -v2 46 | - -Werror 47 | - -O2 48 | - -fprof-auto 49 | - -funbox-strict-fields 50 | dependencies: 51 | - rt-haskell 52 | 53 | tests: 54 | rt-haskell-test: 55 | main: Spec.hs 56 | source-dirs: test 57 | ghc-options: 58 | - -threaded 59 | - -rtsopts 60 | - -with-rtsopts=-N 61 | dependencies: 62 | - rt-haskell 63 | -------------------------------------------------------------------------------- /src/Scene/CheckerScene.hs: -------------------------------------------------------------------------------- 1 | -- Checker scene 2 | module Scene.CheckerScene(twoCheckeredSpheres) where 3 | 4 | import Scene.Scene 5 | 6 | 7 | import Color.ColorInterface 8 | import Color.Pixel 9 | 10 | -- math3d 11 | import Math3D.Vector 12 | import Math3D.CommonOps 13 | 14 | -- hittable 15 | import Hittable.HittableList 16 | import Hittable.HittableObj 17 | import Hittable.Sphere 18 | 19 | -- texture 20 | import Texture.TextureObj 21 | import Texture.SolidColor 22 | import Texture.Checker 23 | 24 | -- material 25 | import Material.Material 26 | 27 | -- utility 28 | import Utility.HelperTypes 29 | 30 | twoCheckeredSpheres :: Scene 31 | twoCheckeredSpheres = 32 | let s1 = SolidD 0.2 0.3 0.1 33 | s2 = SolidD 0.9 0.9 0.8 34 | tobj = TextureCons $! CheckT s1 s2 35 | lmb = LambMat $! LambT tobj 36 | sp1 = SphereObj {sphereCenter = fromList2Vec 0.0 [-10.0, 0.0], 37 | sphereRadius = 10, 38 | sphereMat = lmb} 39 | sp2 = SphereObj {sphereCenter = fromList2Vec 0.0 [10.0, 0.0], 40 | sphereRadius = 10, 41 | sphereMat = lmb} 42 | hs = HList {objects = NList (HittableCons sp1) [HittableCons sp2]} 43 | in SceneVals { 44 | img_width = 256, 45 | aspect_ratio = aspectRatio, 46 | img_height = getImgHeight 256 aspectRatio, 47 | nb_samples = nbSamples, 48 | bounce_depth = bounceDepth, 49 | cam_look_from = camLookFrom, 50 | cam_look_to = camLookTo, 51 | cam_vfov = camVFov, 52 | cam_vup = camVUp, 53 | cam_focus_distance = camFocDistance, 54 | cam_aperture = 0.0, 55 | scene_obj = hs, 56 | sample_obj = hs, 57 | back_ground = PixSpecTrichroma (0.7, 0.8, 1.0) 58 | } 59 | 60 | -------------------------------------------------------------------------------- /src/Scene/ImageScene.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- image scene 3 | module Scene.ImageScene(imgEarth) where 4 | 5 | -- default scene 6 | import Scene.Scene 7 | 8 | -- hittable 9 | import Hittable.HittableList 10 | import Hittable.HittableObj 11 | import Hittable.Sphere 12 | 13 | import Color.Pixel 14 | 15 | -- 16 | import GHC.Float 17 | import Prelude hiding(subtract) 18 | import Data.Bitmap.Base 19 | import Data.Bitmap.Simple 20 | 21 | -- material 22 | import Material.Material 23 | 24 | -- math 25 | import Math3D.Vector 26 | import Math3D.CommonOps 27 | 28 | -- texture 29 | import Texture.TextureObj 30 | import Texture.Image 31 | 32 | -- utility 33 | import Utility.HelperTypes 34 | 35 | 36 | imgEarth :: Bitmap Word8 -> Scene 37 | 38 | imgEarth !bmp = 39 | let 40 | bbmp = bmp 41 | -- bbmp = flipBitmap bmp 42 | -- bbmp = mirrorBitmap bmp 43 | ptex = TextureCons $! bitmapToImageT bbmp 44 | -- ptex = SolidTexture $ SolidV ( VList [0.2, 0.3, 0.1] ) 45 | lmb = LambMat $! LambT ptex 46 | sp2 = SphereObj {sphereCenter = fromList2Vec 0.0 [0.0, 0.0], 47 | sphereRadius = 2, 48 | sphereMat = lmb} 49 | hs = HList {objects = NList (HittableCons sp2) []} 50 | in SceneVals { 51 | img_width = imageWidth, 52 | aspect_ratio = aspectRatio, 53 | img_height = imageHeight, 54 | nb_samples = nbSamples, 55 | bounce_depth = bounceDepth, 56 | cam_look_from = fromList2Vec 0.0 [0.0, 12.0], 57 | cam_look_to = camLookTo, 58 | cam_vfov = camVFov, 59 | cam_vup = camVUp, 60 | cam_focus_distance = camFocDistance, 61 | cam_aperture = 0.0, 62 | scene_obj = hs, 63 | sample_obj = hs, 64 | back_ground = PixSpecTrichroma (0.7,0.8,1.0) 65 | } 66 | 67 | -------------------------------------------------------------------------------- /src/Scene/PerlinSphere.hs: -------------------------------------------------------------------------------- 1 | -- perlin sphere scene 2 | module Scene.PerlinSphere(twoPerlinSpheres) where 3 | 4 | import Scene.Scene 5 | 6 | import Color.Pixel 7 | 8 | -- math 9 | import Math3D.Vector 10 | import Math3D.CommonOps 11 | 12 | -- hittable 13 | import Hittable.HittableList 14 | import Hittable.HittableObj 15 | import Hittable.Sphere 16 | import Hittable.MovingSphere 17 | 18 | -- texture 19 | import Texture.SolidColor 20 | import Texture.TextureObj 21 | import Texture.Noise 22 | 23 | -- material 24 | import Material.Material 25 | 26 | -- random 27 | import System.Random 28 | import GHC.Float 29 | import Random 30 | 31 | import Utility.HelperTypes 32 | 33 | 34 | twoPerlinSpheres :: RandomGen g => g -> Scene 35 | twoPerlinSpheres g = 36 | let ptex = TextureCons $! mkPerlinNoise g 4.0 37 | lmb = LambMat $! LambT ptex 38 | sp1 = SphereObj {sphereCenter = fromList2Vec 0.0 [-1000.0, 0.0], 39 | sphereRadius = 1000, 40 | sphereMat = lmb} 41 | sp2 = SphereObj {sphereCenter = fromList2Vec 0.0 [2.0, 0.0], 42 | sphereRadius = 2, 43 | sphereMat = lmb} 44 | hs = HList {objects = NList (HittableCons sp1) [HittableCons sp2]} 45 | in SceneVals { 46 | img_width = imageWidth, 47 | aspect_ratio = aspectRatio, 48 | img_height = imageHeight, 49 | nb_samples = nbSamples, 50 | bounce_depth = bounceDepth, 51 | cam_look_from = camLookFrom, 52 | cam_look_to = camLookTo, 53 | cam_vfov = camVFov, 54 | cam_vup = camVUp, 55 | cam_focus_distance = camFocDistance, 56 | cam_aperture = 0.0, 57 | scene_obj = hs, 58 | sample_obj = HList {objects = NList (HittableCons sp1) []}, 59 | back_ground = PixSpecTrichroma (0.7,0.8,1.0) 60 | } 61 | 62 | -------------------------------------------------------------------------------- /src/Scene/DiffuseSphere.hs: -------------------------------------------------------------------------------- 1 | -- diffuse sphere scene 2 | module Scene.DiffuseSphere(diffuseSphere) where 3 | 4 | import Scene.Scene 5 | 6 | -- math 7 | import Math3D.Vector 8 | import Math3D.CommonOps 9 | 10 | -- color 11 | import Color.Pixel 12 | 13 | -- hittable 14 | import Hittable.HittableList 15 | import Hittable.HittableObj 16 | import Hittable.Sphere 17 | import Hittable.MovingSphere 18 | 19 | -- texture 20 | import Texture.SolidColor 21 | import Texture.TextureObj 22 | 23 | -- material 24 | import Material.Material 25 | 26 | -- utility 27 | import Utility.HelperTypes 28 | 29 | diffuseSphere :: Scene 30 | diffuseSphere = 31 | let st1 = TextureCons $! SolidD 0.4 0.2 0.1 32 | st2 = TextureCons $! SolidD 0.5 0.5 0.5 33 | sobj = HList {objects = NList ( 34 | HittableCons $! SphereObj { 35 | sphereCenter = fromList2Vec (-4.0) [1.0, 0.0], 36 | sphereRadius = 1.0, 37 | sphereMat = LambMat $! LambT st1 38 | }) [ 39 | HittableCons $ SphereObj { 40 | sphereCenter = fromList2Vec 0.0 [-1000.0, 0.0], 41 | sphereRadius = 1000.0, 42 | sphereMat = LambMat $! LambT st2 43 | } ]} 44 | in SceneVals { 45 | img_width = imageWidth, 46 | aspect_ratio = aspectRatio, 47 | img_height = imageHeight, 48 | nb_samples = nbSamples, 49 | bounce_depth = bounceDepth, 50 | cam_look_from = camLookFrom, 51 | cam_look_to = camLookTo, 52 | cam_vfov = camVFov, 53 | cam_vup = camVUp, 54 | cam_focus_distance = camFocDistance, 55 | cam_aperture = 0.1, 56 | scene_obj = sobj, 57 | sample_obj = sobj, 58 | back_ground = PixSpecTrichroma (0.7,0.8,1.0) 59 | } 60 | -------------------------------------------------------------------------------- /src/Material/Material.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- material module 4 | module Material.Material where 5 | 6 | import Math3D.Vector 7 | import Math3D.Ray 8 | 9 | import Texture.TextureObj 10 | import Texture.Spectral 11 | 12 | -- color related 13 | import Color.ColorInterface 14 | 15 | -- materials 16 | 17 | data Material = LambMat Lambertian 18 | | MetalMat Metal 19 | | DielMat Dielectric 20 | | LightMat DiffuseLight 21 | | IsotMat Isotropic 22 | | SpectralMat SpectralMaterial 23 | | NoMat 24 | 25 | type Color = ColorRecord 26 | 27 | -- data Lambertian = Lamb {lalbedo :: Color} deriving (Eq, Show) 28 | 29 | -- lambertian material 30 | -- data Lambertian = Lamb {lalbedo :: TextureObj} 31 | 32 | data Lambertian where 33 | -- LambC :: Color -> Lambertian 34 | LambT :: TextureObj -> Lambertian 35 | 36 | 37 | -- metal material 38 | -- data Metal = Met {malbedo :: TextureObj, fuzz :: Double } 39 | 40 | data Metal where 41 | -- MetC :: Color -> Double -> Metal 42 | MetT :: TextureObj -> Double -> Metal 43 | 44 | -- dielectric material 45 | data Dielectric where 46 | DielRefIndices :: [Double] -> Dielectric 47 | 48 | schlickRef :: Double -> Double -> Double 49 | schlickRef cosi ref_idx = 50 | let r0 = (1.0 - ref_idx) / (1.0 + ref_idx) 51 | r1 = r0 * r0 52 | pw = (1.0 - cosi) ** 5 53 | in r1 + (1.0 - r1) * pw 54 | 55 | data DiffuseLight where 56 | DLightEmitTextureCons :: TextureObj -> DiffuseLight 57 | -- DLightColorCons :: Color -> DiffuseLight 58 | 59 | 60 | -- isotropic material 61 | 62 | data Isotropic where 63 | IsotTexture :: TextureObj -> Isotropic 64 | -- IsotColor :: Color -> Isotropic 65 | 66 | data SpectralMaterial where 67 | SpectralLamb :: SpectralTexture -> SpectralMaterial 68 | SpectralMetal :: SpectralTexture -> Double -> SpectralMaterial 69 | SpectralLight :: SpectralTexture -> SpectralMaterial 70 | SpectralIsotropic :: SpectralTexture -> SpectralMaterial 71 | -------------------------------------------------------------------------------- /src/Scene/PerlinLight.hs: -------------------------------------------------------------------------------- 1 | -- perlin sphere with light module 2 | module Scene.PerlinLight(simpleLight) where 3 | 4 | -- default values 5 | import Scene.Scene 6 | 7 | import Color.Pixel 8 | 9 | -- math3d 10 | import Math3D.Vector 11 | import Math3D.CommonOps 12 | 13 | -- texture 14 | import Texture.TextureObj 15 | import Texture.Noise 16 | import Texture.SolidColor 17 | 18 | -- hittable 19 | import Hittable.Sphere 20 | import Hittable.HittableObj 21 | import Hittable.HittableList 22 | import Hittable.AaRect 23 | 24 | -- material 25 | import Material.Material 26 | 27 | import Utility.HelperTypes 28 | -- 29 | import System.Random 30 | import Random 31 | 32 | simpleLight :: RandomGen g => g -> Scene 33 | simpleLight g = 34 | let ptex = TextureCons $! mkPerlinNoise g 4.0 35 | lmb = LambMat $! LambT ptex 36 | sp1 = SphereObj {sphereCenter = fromList2Vec 0.0 [-1000.0, 0.0], 37 | sphereRadius = 1000, 38 | sphereMat = lmb} 39 | sp2 = SphereObj {sphereCenter = fromList2Vec 0.0 [2.0, 0.0], 40 | sphereRadius = 2, 41 | sphereMat = lmb} 42 | st1 = TextureCons $! SolidD 4.5 4.5 4.5 43 | lmat = LightMat $! DLightEmitTextureCons st1 44 | dlight = HittableCons $! mkXyRect 3.0 5.0 1.0 3.0 (-2.0) lmat 45 | sp3 = SphereObj {sphereCenter = fromList2Vec 0.0 [8.0, 0.0], 46 | sphereRadius = 2, 47 | sphereMat = lmat} 48 | hs = HList { 49 | objects = NList (HittableCons sp1) [HittableCons sp2, dlight, HittableCons sp3] 50 | } 51 | in SceneVals { 52 | img_width = imageWidth, 53 | aspect_ratio = aspectRatio, 54 | img_height = imageHeight, 55 | nb_samples = 200, 56 | bounce_depth = 100, 57 | cam_look_from = fromList2Vec 26.0 [3.0, 6.0], 58 | cam_look_to = fromList2Vec 0.0 [2.0, 0.0], 59 | cam_vfov = camVFov, 60 | cam_vup = camVUp, 61 | cam_focus_distance = camFocDistance, 62 | cam_aperture = 0.0, 63 | scene_obj = hs, 64 | sample_obj = HList {objects = NList dlight []}, 65 | back_ground = PixSpecTrichroma (0.0, 0.0, 0.0) 66 | } 67 | 68 | -------------------------------------------------------------------------------- /src/Scenes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- scene module 3 | module Scenes where 4 | 5 | import Data.Bitmap.Base 6 | import System.Random 7 | 8 | -- basic scene defaults 9 | import Scene.Scene 10 | 11 | -- diffuse sphere 12 | import Scene.DiffuseSphere 13 | 14 | -- random one weekend final 15 | import Scene.RandomOneWeekendFinal 16 | 17 | -- two spheres for checkered texture 18 | import Scene.CheckerScene 19 | 20 | -- two perlin spheres 21 | import Scene.PerlinSphere 22 | 23 | -- image texture 24 | import Scene.ImageScene 25 | 26 | -- simple light scene 27 | import Scene.PerlinLight 28 | 29 | -- cornell box 30 | import Scene.CornellBox 31 | 32 | -- cornell smoke 33 | import Scene.CornellSmoke 34 | 35 | -- cornell image 36 | import Scene.CornellImage 37 | 38 | -- next week final scene 39 | import Scene.NextWeekFinal 40 | 41 | -- cornell sphere 42 | import Scene.CornellSphere 43 | 44 | -- spectral checker sphere 45 | import Scene.SpectralScene 46 | 47 | chooseScene :: RandomGen g => g -> [Bitmap Word8] -> Int -> (Int, Scene) 48 | chooseScene g !s choice = 49 | case choice of 50 | 0 -> (nb_samples diffuseSphere, diffuseSphere) 51 | 1 -> let sc = randomOneWeekendFinalSceneStatic g in (nb_samples sc, sc) 52 | 2 -> let sc = randomOneWeekendFinalSceneMove g in (nb_samples sc, sc) 53 | 3 -> let sc = twoCheckeredSpheres in (nb_samples sc, sc) 54 | 4 -> let sc = twoPerlinSpheres g in (nb_samples sc, sc) 55 | 5 -> let sc = if null s 56 | then diffuseSphere 57 | else imgEarth (head s) 58 | in (nb_samples sc, sc) 59 | 6 -> let sc = simpleLight g in (nb_samples sc, sc) 60 | 7 -> let sc = cornellBox g in (nb_samples sc, sc) 61 | 8 -> let sc = cornellSmoke g in (nb_samples sc, sc) 62 | 9 -> let sc = if null s 63 | then diffuseSphere 64 | else nextWeekFinal g (head s) 65 | in (nb_samples sc, sc) 66 | 10 -> let sc = cornellSphere g in (nb_samples sc, sc) 67 | 11 -> let sc = cornellBoxSpectral g in (nb_samples sc, sc) 68 | 12 -> let sc = if null s 69 | then diffuseSphere 70 | else cornellBoxDemotic g (head s) in (nb_samples sc, sc) 71 | _ -> let sc = diffuseSphere in (nb_samples sc, sc) 72 | 73 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | resolver: ghc-7.10.3 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | # resolver: 22 | # url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml 23 | 24 | # User packages to be built. 25 | # Various formats can be used as shown in the example below. 26 | # 27 | # packages: 28 | # - some-directory 29 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 30 | # subdirs: 31 | # - auto-update 32 | # - wai 33 | packages: 34 | - . 35 | # Dependency packages to be pulled from upstream that are not in the resolver. 36 | # These entries can reference officially published versions as well as 37 | # forks / in-progress versions pinned to a git hash. For example: 38 | # 39 | extra-deps: 40 | # - acme-missiles-0.3 41 | # - git: https://github.com/commercialhaskell/stack.git 42 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 43 | - random-1.1 44 | - stb-image-0.2.1 45 | - bitmap-0.0.2 46 | 47 | # 48 | # extra-deps: [] 49 | 50 | # Override default flag values for local packages and extra-deps 51 | # flags: {} 52 | 53 | # Extra package databases containing global packages 54 | # extra-package-dbs: [] 55 | 56 | # Control whether we use the GHC we find on the path 57 | system-ghc: true 58 | # 59 | # Require a specific version of stack, using version ranges 60 | # require-stack-version: -any # Default 61 | # require-stack-version: ">=2.7" 62 | # 63 | # Override the architecture used by stack, especially useful on Windows 64 | # arch: i386 65 | # arch: x86_64 66 | # 67 | # Extra directories used by stack for building 68 | # extra-include-dirs: [/path/to/dir] 69 | # extra-lib-dirs: [/path/to/dir] 70 | # 71 | # Allow a newer minor version of GHC than the snapshot specifies 72 | # compiler-check: newer-minor 73 | -------------------------------------------------------------------------------- /src/Hittable/Translatable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | -- rotatable 5 | module Hittable.Translatable where 6 | 7 | import Hittable.Hittable 8 | import Hittable.Aabb 9 | import Hittable.HitRecord 10 | 11 | -- math3d 12 | import Math3D.Matrix 13 | import Math3D.Vector 14 | import Math3D.CommonOps 15 | import Math3D.Ray 16 | import Prelude hiding(subtract) 17 | 18 | 19 | data Translatable where 20 | Translate :: (Show a, Hittable a, Eq a) => a -> Vector -> String -> Translatable 21 | 22 | instance Show Translatable where 23 | show (Translate a offset _) = 24 | let msg1 = "" 26 | 27 | instance Eq Translatable where 28 | a == b = case a of 29 | Translate _ _ an -> 30 | case b of 31 | Translate _ _ bn -> (an == bn) 32 | 33 | instance Hittable Translatable where 34 | hit (Translate a offset _) g !(Rd {origin = ro, 35 | direction = rd, 36 | rtime = rt, 37 | wavelength = rwave}) !tmin !tmax !hrec = 38 | let ry = Rd { origin = subtract ro offset, direction = rd, 39 | rtime = rt, wavelength = rwave } 40 | (srec, isHit, g1) = hit a g ry tmin tmax hrec 41 | in if not isHit 42 | then (srec, isHit, g1) 43 | else let p = add (point srec) offset 44 | HRec { 45 | hdist = h1, point = h2, pnormal = h3, matPtr = h4, 46 | hUV_u = h5, hUV_v = h6, isFront = h7 47 | } = srec 48 | nsrec = HRec {hdist = h1, point = p, pnormal = h3, 49 | matPtr = h4, hUV_u = h5, hUV_v = h6, 50 | isFront = h7} 51 | in (setFaceNormal nsrec ry h3, True, g1) 52 | 53 | boundingBox (Translate a offset _) tmn tmx ab = 54 | let (abound, isBox) = boundingBox a tmn tmx ab 55 | in if not isBox 56 | then (abound, isBox) 57 | else let amin = add (aabbMin abound) offset 58 | amax = add (aabbMax abound) offset 59 | in (AaBbox {aabbMin = amin, aabbMax = amax}, True) 60 | 61 | pdf_value a g orig v = 62 | case a of 63 | Translate b oset _ -> pdf_value b g (subtract orig oset) v 64 | hrandom a g orig = 65 | case a of 66 | Translate b oset _ -> hrandom b g (subtract orig oset) 67 | -------------------------------------------------------------------------------- /src/Math3D/EulerAngles.hs: -------------------------------------------------------------------------------- 1 | -- euler angles logic 2 | module Math3D.EulerAngles where 3 | 4 | import Math3D.Vector 5 | 6 | data EulerAngleType = YAW | PITCH | ROLL deriving(Eq, Show) 7 | 8 | data EulerAngle = EuAngle { 9 | eulerVal :: Double, 10 | eulerHigh :: Double, 11 | eulerLow :: Double, 12 | eulerIsLimited :: Bool, 13 | angleType :: EulerAngleType 14 | } deriving(Eq, Show) 15 | 16 | eulerValue :: EulerAngle -> Double 17 | eulerValue eangle = 18 | let ehigh = eulerHigh eangle 19 | elow = eulerLow eangle 20 | evalue = eulerVal eangle 21 | in if eulerIsLimited eangle 22 | then if evalue < elow 23 | then elow 24 | else if evalue > ehigh 25 | then ehigh 26 | else evalue 27 | else evalue 28 | 29 | data EulerAngles = EuAngles { 30 | eulerRoll :: EulerAngle, 31 | eulerYaw :: EulerAngle, 32 | eulerPitch :: EulerAngle 33 | } deriving(Eq, Show) 34 | 35 | eulerToVec :: EulerAngles -> Vector 36 | eulerToVec eangles = 37 | let roll = eulerValue $ eulerRoll eangles 38 | pitch = eulerValue $ eulerPitch eangles 39 | yaw = eulerValue $ eulerYaw eangles 40 | in fromList2Vec roll [pitch, yaw] 41 | 42 | 43 | fromValsToEuler :: Double -> Double -> Double -> EulerAngles 44 | fromValsToEuler roll pitch yaw = 45 | let rollAngle = EuAngle{ eulerVal = roll, 46 | eulerHigh = 0, 47 | eulerLow = 0, 48 | eulerIsLimited = False, 49 | angleType = ROLL 50 | } 51 | pitchAngle = EuAngle{ eulerVal = pitch, 52 | eulerHigh = 0, 53 | eulerLow = 0, 54 | eulerIsLimited = False, 55 | angleType = PITCH 56 | } 57 | yawAngle = EuAngle{ eulerVal = yaw, 58 | eulerHigh = 0, 59 | eulerLow = 0, 60 | eulerIsLimited = False, 61 | angleType = YAW} 62 | in EuAngles {eulerRoll = rollAngle, 63 | eulerYaw = yawAngle, 64 | eulerPitch = pitchAngle} 65 | 66 | 67 | toFrontVec :: EulerAngles -> Vector 68 | toFrontVec eangles = 69 | let yaw = eulerVal $ eulerYaw eangles 70 | pitch = eulerVal $ eulerPitch eangles 71 | f = (cos yaw) * (cos pitch) 72 | in fromList2Vec f [sin pitch, (sin yaw) * (cos pitch)] 73 | -------------------------------------------------------------------------------- /src/Math3D/Onb.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- onb in haskell 3 | module Math3D.Onb where 4 | 5 | import Math3D.Vector 6 | import Math3D.CommonOps 7 | import Math3D.EulerAngles 8 | import Utility.HelperTypes 9 | 10 | data OrthoNormalBase = Onb (NonEmptyList Vector) 11 | 12 | onbSize :: OrthoNormalBase -> Int 13 | onbSize (Onb nl) = lengthNL nl 14 | 15 | onbSizeCheck :: OrthoNormalBase -> Int -> Either String Bool 16 | onbSizeCheck onb size = 17 | if onbSize onb < size 18 | then Left $ "ortho normal base have less than requested size " ++ show size 19 | else Right True 20 | 21 | vBasis :: OrthoNormalBase -> Vector 22 | vBasis onb = case onbSizeCheck onb 3 of 23 | Left s -> error s 24 | Right _ -> let Onb olst = onb in getNL olst 1 25 | 26 | upDir :: OrthoNormalBase -> Vector 27 | upDir = vBasis 28 | 29 | wBasis :: OrthoNormalBase -> Vector 30 | wBasis onb = case onbSizeCheck onb 3 of 31 | Left s -> error s 32 | Right _ -> let Onb olst = onb in getNL olst 0 33 | 34 | frontDir :: OrthoNormalBase -> Vector 35 | frontDir = wBasis 36 | 37 | uBasis :: OrthoNormalBase -> Vector 38 | uBasis onb = case onbSizeCheck onb 3 of 39 | Left s -> error s 40 | Right _ -> let Onb olst = onb in getNL olst 2 41 | 42 | rightDir :: OrthoNormalBase -> Vector 43 | rightDir = uBasis 44 | 45 | onb3 :: Vector -> Vector -> Vector -> OrthoNormalBase 46 | onb3 w v u = Onb $ NList w [v, u] 47 | 48 | localVec :: OrthoNormalBase -> Vector -> Vector 49 | localVec ob t = 50 | let u = uBasis ob 51 | v = vBasis ob 52 | w = wBasis ob 53 | ux = multiplyS u $ vget t 0 54 | vy = multiplyS v $ vget t 1 55 | wz = multiplyS w $ vget t 2 56 | in add wz (add ux vy) 57 | 58 | localXyz :: OrthoNormalBase -> Double -> Double -> Double -> Vector 59 | localXyz ob x y z = localVec ob ( VList (fromList2NL x [y, z]) ) 60 | 61 | fromW2Onb :: Vector -> OrthoNormalBase 62 | fromW2Onb wvec = 63 | let w = toUnit wvec 64 | wx = vget w 0 65 | a = if (abs wx) > 0.9 66 | then VList $! fromList2NL 0.0 [1.0, 0.0] 67 | else VList $! fromList2NL 1.0 [0.0, 0.0] 68 | v = toUnit $! cross3d w a 69 | u = cross3d w v 70 | in onb3 w v u 71 | 72 | 73 | fromWUp2Onb :: Vector -> Vector -> OrthoNormalBase 74 | fromWUp2Onb wvec upvec = 75 | let w = toUnit wvec 76 | a = toUnit upvec 77 | v = toUnit $! cross3d w a 78 | u = cross3d w v 79 | in onb3 w v u 80 | 81 | fromEuler2Onb :: EulerAngles -> OrthoNormalBase 82 | fromEuler2Onb eangles = 83 | let w = toFrontVec eangles 84 | in fromW2Onb w 85 | 86 | fromEulerUp2Onb :: EulerAngles -> Vector -> OrthoNormalBase 87 | fromEulerUp2Onb eangles upv = let w = toFrontVec eangles in fromWUp2Onb w upv 88 | -------------------------------------------------------------------------------- /src/Hittable/HittableList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- hittable list module contains hittables and related 3 | module Hittable.HittableList where 4 | 5 | -- hittable 6 | import Hittable.Hittable 7 | import Hittable.HittableObj 8 | import Hittable.Sphere 9 | import Hittable.MovingSphere 10 | import Hittable.Aabb 11 | import Hittable.HitRecord 12 | 13 | -- material 14 | import Material.Material 15 | 16 | -- utility etc 17 | import Utility.HelperTypes 18 | import Random 19 | 20 | -- third party 21 | import Data.List 22 | import Data.Function 23 | import GHC.Float 24 | 25 | 26 | data HittableList = HList {objects :: NonEmptyList HittableObj} 27 | 28 | 29 | instance Hittable HittableList where 30 | {-# INLINE hit #-} 31 | hit !hobj g !ry !tmin !tmax !hrec = 32 | let hs = nl2List $ objects hobj 33 | hitobjs = hits g tmax hs hrec -- [(hrec, Bool)] 34 | in if null hitobjs 35 | then (hrec, False, g) 36 | else minimumBy (compare `on` hrecDist) hitobjs 37 | where hits _ _ [] _ = [] 38 | hits g1 mx (t:ts) hr = 39 | let (nhrec, isHit, g2) = hit t g1 ry tmin mx hr 40 | nhdist = hdist nhrec 41 | in if isHit 42 | then (nhrec, isHit, g2) : hits g2 nhdist ts nhrec 43 | else hits g2 mx ts hr 44 | hrecDist (a, _, _) = hdist a 45 | 46 | boundingBox !hobjs !time0 !time1 !ab = 47 | let tempBox = zeroAabb3 48 | hs = nl2List $! objects hobjs 49 | firstBox = True 50 | in bbox firstBox time0 time1 tempBox hs ab 51 | where bbox False t0 t1 tbox [] outBox = (outBox, True) 52 | bbox fbox t0 t1 tbox (htl:htls) outBox = 53 | let (sbox, hasBox) = boundingBox htl t0 t1 tbox 54 | in if hasBox == False 55 | then (tbox, False) 56 | else if fbox 57 | then bbox False t0 t1 sbox htls sbox 58 | else let obox = ssBox outBox sbox 59 | in bbox False t0 t1 sbox htls obox 60 | 61 | pdf_value hobjs gen orig dir = 62 | let weight = 1.0 / (int2Double $ lengthNL (objects hobjs)) 63 | fn acc hobj = let RandResult (sumval, g) = acc 64 | resPval = pdf_value hobj g orig dir 65 | res2 = rfmap (+ sumval) resPval 66 | in rfmap (* weight) res2 67 | objs = nl2List $! objects hobjs 68 | in foldl fn (RandResult (0.0, gen)) objs 69 | 70 | hrandom hobjs gen orig = 71 | let upper = lengthNL $! objects hobjs 72 | -- randomInt produces random values in a closed range 73 | resIndex = randomInt gen (0, (upper - 1)) 74 | RandResult (obj, g2) = rfmap (getNL (objects hobjs)) resIndex 75 | in hrandom obj g2 orig 76 | -------------------------------------------------------------------------------- /src/Spectral/SpectrumUtils.hs: -------------------------------------------------------------------------------- 1 | -- spectral utils 2 | module Spectral.SpectrumUtils where 3 | 4 | -- math related 5 | import Math3D.Matrix 6 | import Math3D.Vector 7 | import Math3D.CommonOps 8 | 9 | -- utilities 10 | import Utility.HelperTypes 11 | 12 | xyzRgb_transform :: Vector -> (Vector, Vector, Vector, Vector) -> Vector 13 | xyzRgb_transform xyz (row1, row2, row3, row4) = 14 | let m = mzero 4 4 15 | m1 = msetRow m 0 row1 16 | m2 = msetRow m1 1 row2 17 | m3 = msetRow m2 2 row3 18 | m4 = msetRow m3 3 row4 19 | (x, y, z) = (vget xyz 0, vget xyz 1, vget xyz 2) 20 | v = fromList2Vec x [y, z, 0.0] 21 | mvec = matFromVector (fromList2NL v []) 22 | mat = matmul mvec m4 23 | [r,g,b,w] = nl2List $! mdata mat 24 | in fromList2Vec r [g, b] 25 | 26 | 27 | xyz2rgb_cie :: Vector -> Vector 28 | xyz2rgb_cie xyz = let row1 = fromList2Vec 2.3706743 [-0.5138850, 0.0052982, 0.0] 29 | row2 = fromList2Vec (-0.9000405) [1.4253036, -0.0146949, 0.0] 30 | row3 = fromList2Vec (-0.4706338) [0.0885814, 1.0093968, 0.0] 31 | row4 = fromList2Vec 0.0 [0.0, 0.0, 1.0] 32 | in xyzRgb_transform xyz (row1, row2, row3, row4) 33 | 34 | xyz2rgb_srgb :: Vector -> Vector 35 | xyz2rgb_srgb xyz = let row1 = fromList2Vec 3.2404542 [-0.9692660, 0.0556434, 0.0] 36 | row2 = fromList2Vec (-1.5371385) [1.8760108, -0.2040259, 0.0] 37 | row3 = fromList2Vec (-0.4985314) [0.0415560, 1.0572252, 0.0] 38 | row4 = fromList2Vec 0.0 [0.0, 0.0, 1.0] 39 | in xyzRgb_transform xyz (row1, row2, row3, row4) 40 | 41 | xyz2rgb_pbr :: Vector -> Vector 42 | xyz2rgb_pbr xyz = let (x, y, z) = (vget xyz 0, vget xyz 1, vget xyz 2) 43 | r = x * 3.240479 - 1.537150 * y - 0.498535 * z 44 | g = x * (-0.969256) + 1.875991 * y + 0.041556 * z 45 | b = x * 0.055648 - 0.204043 * y + 1.057311 * z 46 | in fromList2Vec r [g, b] 47 | 48 | 49 | rgb2xyz_srgb :: Vector -> Vector 50 | rgb2xyz_srgb rgb = let row1 = fromList2Vec 0.4124564 [0.2126729, 0.0193339, 0.0] 51 | row2 = fromList2Vec 0.3575761 [0.7151522, 0.1191920, 0.0] 52 | row3 = fromList2Vec 0.1804375 [0.0721750, 0.9503041, 0.0] 53 | row4 = fromList2Vec 0.0 [0.0, 0.0, 1.0] 54 | in xyzRgb_transform rgb (row1, row2, row3, row4) 55 | 56 | rgb2xyz_cie :: Vector -> Vector 57 | rgb2xyz_cie rgb = let row1 = fromList2Vec 0.4887180 [0.1762044, 0.0, 0.0] 58 | row2 = fromList2Vec 0.3106803 [0.8129847, 0.0102048, 0.0] 59 | row3 = fromList2Vec 0.2006017 [0.0108109, 0.9897952, 0.0] 60 | row4 = fromList2Vec 0.0 [0.0, 0.0, 1.0] 61 | in xyzRgb_transform rgb (row1, row2, row3, row4) 62 | -------------------------------------------------------------------------------- /src/Color/ColorIO.hs: -------------------------------------------------------------------------------- 1 | -- color input output, conversion module 2 | module Color.ColorIO where 3 | 4 | import GHC.Float hiding(clamp) 5 | 6 | import Math3D.Vector 7 | import Math3D.CommonOps 8 | 9 | import Color.ColorInterface 10 | import Color.Pixel 11 | import Color.Colorable 12 | import Spectral.SampledSpectrum 13 | import Spectral.SampledDistribution 14 | 15 | import Utility.Utils 16 | import Utility.BaseEnum 17 | 18 | import Debug.Trace 19 | 20 | -- print vector 21 | vecToInt :: Vector -> [Int] 22 | vecToInt v = map double2Int (vec2List v) 23 | 24 | nanError :: String 25 | nanError = let m1 = "NanError :: Pixel spectrum" 26 | m2 = m1 ++ " contains" 27 | m3 = m2 ++ " only nan values. This should not be the case." 28 | in m3 29 | 30 | 31 | nanCheck :: NaNBehavior -> Vector -> Vector 32 | nanCheck (REPLACE_NAN e) v = let repNan d = if isNaN d then e else d 33 | (x:xs) = map repNan (vec2List v) 34 | in fromList2Vec x xs 35 | 36 | nanCheck nb v 37 | | nb == ALL_NAN = if all isNaN (vec2List v) 38 | then traceStack (nanError ++ show v) v 39 | else v 40 | | nb == ANY_NAN = if any isNaN (vec2List v) 41 | then traceStack (nanError ++ show v) v 42 | else v 43 | | otherwise = v 44 | 45 | 46 | pixSpectrum2RGB :: PixelSpectrum -> Int -> Vector 47 | pixSpectrum2RGB pspec sample_nb = 48 | let scale = 1.0 / int2Double sample_nb 49 | mfn v = multiplyS v scale 50 | cdata = pixelSpectrumData pspec 51 | in if any isNaN (vec2List cdata) 52 | then traceStack nanError zeroV3 53 | else case pspec of 54 | PixSpecSampled s -> 55 | let -- scaledwp = mfn (sampled s) 56 | scaledwp = sampled s 57 | scaledSpectrum = SSpec { 58 | spectrumType = spectrumType s, 59 | sampled = scaledwp 60 | } 61 | in toRGB scaledSpectrum 62 | PixSpecTrichroma (r,g,b) -> mfn (fromList2Vec r [g, b]) 63 | 64 | writeColor :: PixelSpectrum -> Int -> String 65 | writeColor pspec sample_nb = 66 | let sv = pixSpectrum2RGB pspec sample_nb 67 | nvints = case pspec of 68 | PixSpecTrichroma _ -> 69 | let svgamma = nanCheck ANY_NAN $! vecScalarOp sqrt sv 70 | nsv = nanCheck ANY_NAN $! clampV svgamma 0.0 0.999 71 | nv = nanCheck ANY_NAN $! multiplyS nsv 256.0 72 | in vecToInt nv 73 | PixSpecSampled _ -> 74 | let 75 | -- svgamma = nanCheck ZERO_NAN $! vecScalarOp sqrt sv 76 | svgamma = sv 77 | nsv = nanCheck ANY_NAN $! clampV svgamma 0.0 0.999 78 | nv = nanCheck ANY_NAN $! multiplyS nsv 256.0 79 | in vecToInt nv 80 | in unwords $! map show nvints 81 | -- in traceStack (show sv) "" 82 | -------------------------------------------------------------------------------- /src/Utility/HelperTypes.hs: -------------------------------------------------------------------------------- 1 | -- helper types 2 | module Utility.HelperTypes where 3 | 4 | import Debug.Trace 5 | import Data.List 6 | 7 | data NonEmptyList a = NList a [a] 8 | 9 | headNL :: NonEmptyList a -> a 10 | headNL (NList a _) = a 11 | 12 | tailNL :: NonEmptyList a -> [a] 13 | tailNL (NList _ a) = a 14 | 15 | initNL :: NonEmptyList a -> [a] 16 | initNL (NList a b) = if null b 17 | then [a] 18 | else [a] ++ (init b) 19 | 20 | lastNL :: NonEmptyList a -> a 21 | lastNL (NList a b) = if null b 22 | then a 23 | else last b 24 | 25 | lengthNL :: NonEmptyList a -> Int 26 | lengthNL (NList a b) = 1 + length b 27 | 28 | nl2List :: NonEmptyList a -> [a] 29 | nl2List (NList a b) = [a] ++ b 30 | 31 | fromList2NL :: a -> [a] -> NonEmptyList a 32 | fromList2NL a b = NList a b 33 | 34 | getNL :: NonEmptyList a -> Int -> a 35 | getNL a index = if (index >= lengthNL a) || (index < 0) 36 | then let m = "IndexError :: index: " ++ show index ++ " out of bounds " 37 | m2 = "number of elements " ++ show (lengthNL a) 38 | in traceStack (m ++ m2) (headNL a) 39 | else (nl2List a) !! index 40 | 41 | mapNL :: (a -> b) -> NonEmptyList a -> NonEmptyList b 42 | mapNL f n = let (m:ms) = map f (nl2List n) in fromList2NL m ms 43 | 44 | foldlNL :: (a -> b -> a) -> a -> NonEmptyList b -> a 45 | foldlNL f acc n = let ms = nl2List n in foldl f acc ms 46 | 47 | zipNL :: NonEmptyList a -> NonEmptyList b -> NonEmptyList (a, b) 48 | zipNL a b = let (m:ms) = zip (nl2List a) (nl2List b) in fromList2NL m ms 49 | 50 | sortNL :: Ord a => NonEmptyList a -> NonEmptyList a 51 | sortNL a = let (m:ms) = sort $! nl2List a in fromList2NL m ms 52 | 53 | minNL :: Ord a => NonEmptyList a -> a 54 | minNL a = let (m:ms) = nl2List a in minimum (m:ms) 55 | 56 | maxNL :: Ord a => NonEmptyList a -> a 57 | maxNL a = let (m:ms) = nl2List a in maximum (m:ms) 58 | 59 | minmaxByNL :: (a -> a -> Ordering) -> Bool -> NonEmptyList a -> a 60 | minmaxByNL f b m = let ms = nl2List m in if b 61 | then maximumBy f ms 62 | else minimumBy f ms 63 | 64 | maximumByNL :: (a -> a -> Ordering) -> NonEmptyList a -> a 65 | maximumByNL f m = minmaxByNL f True m 66 | 67 | minimumByNL :: (a -> a -> Ordering) -> NonEmptyList a -> a 68 | minimumByNL f m = minmaxByNL f False m 69 | 70 | reverseNL :: NonEmptyList a -> NonEmptyList a 71 | reverseNL a = let (m:ms) = reverse $ nl2List a in fromList2NL m ms 72 | 73 | elemNL :: Eq a => a -> NonEmptyList a -> Bool 74 | elemNL m b = let ms = nl2List b in m `elem` ms 75 | 76 | findNL :: (a -> Bool) -> NonEmptyList a -> Maybe a 77 | findNL f m = let ms = nl2List m in find f ms 78 | 79 | partitionNL :: (a -> Bool) -> NonEmptyList a -> ([a], [a]) 80 | partitionNL f m = let ms = nl2List m in partition f ms 81 | 82 | 83 | instance Eq a => Eq (NonEmptyList a) where 84 | a == b = (nl2List a) == (nl2List b) 85 | 86 | instance Show a => Show (NonEmptyList a) where 87 | show a = show (nl2List a) 88 | -------------------------------------------------------------------------------- /rt-haskell.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: rt-haskell 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/githubuser/rt-haskell#readme 11 | bug-reports: https://github.com/githubuser/rt-haskell/issues 12 | author: Author name here 13 | maintainer: example@example.com 14 | copyright: 2021 Author name here 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-source-files: 19 | README.md 20 | ChangeLog.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/githubuser/rt-haskell 25 | 26 | library 27 | exposed-modules: 28 | Camera 29 | Color 30 | ColorIO 31 | Hittable.Aabb 32 | Hittable.AaRect 33 | Hittable.Bvh 34 | Hittable.HitRecord 35 | Hittable.Hittable 36 | Hittable.HittableList 37 | Hittable.HittableObj 38 | Hittable.MovingSphere 39 | Hittable.Rotatable 40 | Hittable.Sphere 41 | Hittable.Translatable 42 | Hittable.Translate 43 | Instance.Box 44 | Lib 45 | Material.Material 46 | Material.Scatter 47 | Math3D.CommonOps 48 | Math3D.EulerAngles 49 | Math3D.Matrix 50 | Math3D.Onb 51 | Math3D.Quaternion 52 | Math3D.Ray 53 | Math3D.Transform 54 | Math3D.Vector 55 | Pixel 56 | Random 57 | Scene.CheckerScene 58 | Scene.CornellBox 59 | Scene.DiffuseSphere 60 | Scene.ImageScene 61 | Scene.PerlinLight 62 | Scene.PerlinSphere 63 | Scene.RandomOneWeekendFinal 64 | Scene.Scene 65 | Scenes 66 | Texture.Checker 67 | Texture.Image 68 | Texture.Noise 69 | Texture.SolidColor 70 | Texture.Texture 71 | Texture.TextureObj 72 | Utility.HelperTypes 73 | Utility.Utils 74 | other-modules: 75 | Paths_rt_haskell 76 | hs-source-dirs: 77 | src 78 | build-depends: 79 | base >=4.8.2.0 80 | , bitmap >=0.0.2 81 | , containers >=0.5.6.2 82 | , random >=1.1 83 | , stb-image >=0.2.1 84 | , time >=1.5.0 85 | default-language: Haskell2010 86 | 87 | executable rt-haskell.out 88 | main-is: Main.hs 89 | other-modules: 90 | Paths_rt_haskell 91 | hs-source-dirs: 92 | app 93 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror -O2 -prof -fprof-auto -funbox-strict-fields 94 | build-depends: 95 | base >=4.8.2.0 96 | , bitmap >=0.0.2 97 | , containers >=0.5.6.2 98 | , random >=1.1 99 | , rt-haskell 100 | , stb-image >=0.2.1 101 | , time >=1.5.0 102 | default-language: Haskell2010 103 | 104 | test-suite rt-haskell-test 105 | type: exitcode-stdio-1.0 106 | main-is: Spec.hs 107 | other-modules: 108 | Paths_rt_haskell 109 | hs-source-dirs: 110 | test 111 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 112 | build-depends: 113 | base >=4.8.2.0 114 | , bitmap >=0.0.2 115 | , containers >=0.5.6.2 116 | , random >=1.1 117 | , rt-haskell 118 | , stb-image >=0.2.1 119 | , time >=1.5.0 120 | default-language: Haskell2010 121 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main where 3 | -- stack install --profile --local-bin-path ./bin/ 4 | -- options +RTS (enables statistics) -N2 (two threads) -p 5 | -- the order of options is important 6 | 7 | import Render 8 | import Color.Pixel 9 | import Color.ColorIO 10 | import System.Random 11 | import Prelude hiding(subtract) 12 | import Data.Time.Clock 13 | import System.IO 14 | import Codec.Image.STB 15 | 16 | import Scene.Scene 17 | 18 | import Scenes 19 | 20 | -- world 21 | 22 | -- camera related 23 | 24 | -- rendering ppm related 25 | printPPMHeader :: Int -> Int -> IO () 26 | printPPMHeader imw imh = do 27 | putStrLn "P3" 28 | putStrLn $ show imw ++ " " ++ show imh 29 | putStrLn "255" 30 | 31 | -- make pixel colors from pixel coordinates 32 | 33 | printPixel :: Pixel -> Int -> IO () 34 | printPixel !(Pix {x = _, y = _, color = cs}) !smpl = 35 | let cstring = writeColor cs smpl 36 | in putStrLn cstring 37 | 38 | printPixels :: [Pixel] -> Int -> IO () 39 | printPixels ![] _ = return () 40 | printPixels !(p:ps) nbsmp = do 41 | _ <- printPixel p nbsmp 42 | printPixels ps nbsmp 43 | 44 | type ImLoad = Either String Image 45 | 46 | -- sceneChoice 47 | -- 0: diffuse, 1: oneweekend final 48 | -- 2: oneweekend final with motion blur 49 | -- 3: checkered sphere 50 | -- 4: perlin noise sphere 51 | -- 5: image texture 52 | 53 | traceScene :: RandomGen g => g-> MayImage -> Int -> IO (Int, (Int, Int), [Pixel]) 54 | traceScene g imD sceneChoice = 55 | let imval = case imD of 56 | Nothing -> [] 57 | Just e -> [e] 58 | (smpl, scne) = chooseScene g imval sceneChoice 59 | imw = img_width scne 60 | imh = img_height scne 61 | jjs = reverse [0..(imh-1)] 62 | iis = [0..(imw-1)] 63 | pixCoords = [(j,i) | j <- jjs, -- outer loop first 64 | i <- iis] 65 | ps = renderScene pixCoords g scne 66 | in return (smpl, (imw, imh), ps) 67 | 68 | type MayImage = Maybe Image 69 | 70 | loadImages :: Int -> [String] -> IO MayImage 71 | loadImages choice paths = 72 | let choiceResult = case choice of 73 | -- earth scene 74 | 5 -> loadImage (head paths) 75 | -- nextweek final scene 76 | 9 -> loadImage (head paths); 77 | -- demotic cornell box scene 78 | 12 -> loadImage (last paths); 79 | _ -> return (Left "no image"); 80 | in do 81 | ioResult <- choiceResult; 82 | case ioResult of 83 | Right a -> return (Just a) 84 | Left _ -> return Nothing 85 | 86 | 87 | printColor :: IO () 88 | printColor = do 89 | tstart <- getCurrentTime 90 | g <- newStdGen 91 | choice <- return 11 92 | imD <- loadImages choice ["./earthmap.jpg", "./demotic.jpg"] 93 | (smpl, (imw, imh), ps) <- traceScene g imD choice 94 | -- print pixCoords 95 | _ <- printPPMHeader imw imh 96 | _ <- printPixels ps smpl 97 | tend <- getCurrentTime 98 | let {diff = diffUTCTime tend tstart; 99 | secs = diff 100 | } 101 | hPutStrLn stderr ("duration in seconds: " ++ show secs ) 102 | 103 | 104 | 105 | main :: IO () 106 | main = printColor 107 | -------------------------------------------------------------------------------- /src/Utility/Utils.hs: -------------------------------------------------------------------------------- 1 | -- utility function 2 | module Utility.Utils where 3 | 4 | import Data.List 5 | import Data.Bits 6 | import Debug.Trace 7 | 8 | import GHC.Float hiding (clamp) 9 | 10 | infty :: Double 11 | infty = (read "Infinity") :: Double 12 | 13 | m_pi :: Double 14 | m_pi = 3.141592653589793238 15 | 16 | float_max :: Double 17 | float_max = 1e37 -- from c++ 18 | 19 | float_min :: Double 20 | float_min = 1e-37 -- from c++ 21 | 22 | degrees_to_radians :: Double -> Double 23 | degrees_to_radians degrees = degrees * m_pi / 180.0 24 | 25 | clamp :: Ord a => a -> a -> a -> a 26 | 27 | clamp x min max = if x < min 28 | then min 29 | else if x > max 30 | then max 31 | else x 32 | 33 | -- interpolate a value in one range to another range 34 | interp :: (Double, Double) -> (Double, Double) -> Double -> Double 35 | interp (inputStart, inputEnd) (outputStart, outputEnd) value = 36 | let idiff = (value - inputStart) / (inputEnd - inputStart) 37 | odiff = outputEnd - outputStart 38 | in idiff * odiff + outputStart 39 | 40 | -- find the corresponding interval given a function and a value 41 | checkMiddle :: Int -> Int -> Int -> Int -> (Int -> Bool) -> (Int, Int) 42 | checkMiddle middle fs lval hlf intervalFn = 43 | if intervalFn middle 44 | then (middle + 1, lval - (hlf + 1)) 45 | else (fs, hlf) 46 | 47 | findInterval :: Int -> (Int -> Bool) -> Int 48 | findInterval size intervalFn = 49 | let first = 0 50 | len = size 51 | -- 52 | halfSearch lval fs = let hlf = lval `shiftR` 1 53 | middle = fs + hlf 54 | (nfs, nlval) = checkMiddle middle fs lval hlf intervalFn 55 | in if nlval > 0 56 | then halfSearch nlval nfs 57 | else (nfs, nlval) 58 | (nfirst, _) = halfSearch len first 59 | in clamp (nfirst - 1) 0 (size - 2) 60 | 61 | 62 | mix :: Fractional a => a -> a -> a -> a 63 | mix t v u = (1.0 - t) * v + t * u 64 | -- 65 | eqReduce :: Eq a => [a] -> ((a -> Bool) -> [a] -> Bool) -> Bool 66 | eqReduce lst f = case lst of 67 | [] -> True 68 | (x:xs) -> f (== x) (x:xs) 69 | 70 | allEqual :: Eq a => [a] -> Bool 71 | allEqual lst = eqReduce lst all 72 | 73 | 74 | anyEqual :: Eq a => [a] -> Bool 75 | anyEqual lst = eqReduce lst any 76 | 77 | -- enumerate 78 | enumerate :: [a] -> [(Int, a)] 79 | enumerate a = zip [0..((length a)-1)] a 80 | 81 | -- take between 82 | takeBetween :: Int -> Int -> [a] -> [a] 83 | takeBetween mnv mxv lst = 84 | let (mn, mx) = if mnv < mxv 85 | then (mnv, mxv) 86 | else (mxv, mnv) 87 | in if mn < 0 88 | then traceStack "minimum value is smaller than zero in takeBetween" [] 89 | else if mx > (length lst) 90 | then let lstlen = "list size " ++ show (length lst) 91 | mxstr = "maximum value " ++ show mx 92 | msg = "maximum value is bigger than list size " 93 | in traceStack (msg ++ lstlen ++ mxstr) [] 94 | else let enums = enumerate lst 95 | pred (i, a) = i >= mn && i <= mx 96 | subseq = filter pred enums 97 | (nms, els) = unzip subseq 98 | in els 99 | 100 | -- 101 | word2Int :: Word -> Int 102 | word2Int a = fromIntegral a 103 | 104 | int2Word :: Int -> Word 105 | int2Word a = fromIntegral a 106 | 107 | double2Word :: Double -> Word 108 | double2Word a = fromIntegral $ double2Int a 109 | 110 | -- debug utilities 111 | debugTraceStr :: Show a => [a] -> String 112 | debugTraceStr xs = intercalate "\n " (map show xs) 113 | -------------------------------------------------------------------------------- /src/Scene/CornellBox.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- cornell box 3 | module Scene.CornellBox(cornellBox) where 4 | 5 | -- scene default values 6 | import Scene.Scene 7 | 8 | import Color.ColorInterface 9 | import Color.Pixel 10 | -- 11 | import System.Random 12 | import Random 13 | 14 | -- math 15 | import Math3D.Vector 16 | import Math3D.Ray 17 | 18 | -- texture 19 | import Texture.SolidColor 20 | import Texture.TextureObj 21 | 22 | -- hittable 23 | import Hittable.HittableList 24 | import Hittable.HittableObj 25 | import Hittable.Hittable 26 | import Hittable.AaRect 27 | import Hittable.Rotatable 28 | import Hittable.Translatable 29 | import Hittable.FlipFace 30 | 31 | -- instance 32 | import Instance.Box 33 | 34 | -- 35 | import Camera 36 | import Material.Material 37 | 38 | -- 39 | import Utility.HelperTypes 40 | 41 | cornellBox :: RandomGen g => g -> Scene 42 | cornellBox gen = 43 | let cfrom = fromList2Vec 278.0 [ 278.0, -800.0] 44 | cto = fromList2Vec 278.0 [ 278.0, 0.0] 45 | cvfov = 40.0 46 | -- set up camera 47 | sceneC = mkCamTime cfrom cto camVUp cvfov aspectRatio 0.0 camFocDistance 48 | whiteTexture = TextureCons $! SolidD 0.75 0.75 0.75 49 | redTexture = TextureCons $! SolidD 0.65 0.05 0.05 50 | greenTexture = TextureCons $! SolidD 0.12 0.45 0.15 51 | highWhiteTexture = TextureCons $! SolidD 15.0 15.0 15.0 52 | 53 | whiteMat = LambMat $! LambT whiteTexture 54 | redMat = LambMat $! LambT redTexture 55 | greenMat = LambMat $! LambT greenTexture 56 | lightMat = LightMat $! DLightEmitTextureCons highWhiteTexture 57 | -- cornell walls 58 | c1 = 0.0 59 | c2 = 555.0 60 | -- yz walls 61 | yzGreenWall = HittableCons $ mkYzRect c1 c2 c1 c2 c2 greenMat 62 | yzRedWall = HittableCons $ mkYzRect c1 c2 c1 c2 c1 redMat 63 | -- xz walls 64 | xzWhiteWall1 = HittableCons $ mkXzRect c1 c2 c1 c2 c2 whiteMat 65 | xzWhiteWall2 = HittableCons $ mkXzRect c1 c2 c1 c2 c1 whiteMat 66 | -- xy wall 67 | xyWhiteWall = HittableCons $ mkXyRect c1 c2 c1 c2 c2 whiteMat 68 | -- light 69 | lightRect = mkXzRect 213.0 343.0 227.0 332.0 554.0 lightMat 70 | lightFlip = FlipHittable lightRect (show lightRect) 71 | lightR = HittableCons lightFlip 72 | 73 | -- boxes 74 | -- get locating parameters 75 | loc = getCameraLocatingParams gen sceneC 76 | (_, _, time) = loc 77 | b1 = mkBox (zeroV3) (fromList2Vec 165.0 [ 330.0, 165.0]) whiteMat 78 | b1rot = mkRotatable b1 45.0 RY (show b1) 79 | b1off = fromList2Vec 265.0 [0.0, 295.0] 80 | b1trans = HittableCons $! Translate b1rot b1off (show b1rot) 81 | b2 = mkBox (zeroV3) (fromList2Vec 165.0 [ 165.0, 165.0]) whiteMat 82 | b2rot = mkRotatable b2 (-18.0) RY (show b2) 83 | b2off = fromList2Vec 130.0 [0.0, 65.0] 84 | b2trans = HittableCons $! Translate b2rot b2off (show b2rot) 85 | 86 | hs = HList {objects = NList (b1trans) [b2trans, yzGreenWall, yzRedWall, 87 | xzWhiteWall1, xzWhiteWall2, 88 | xyWhiteWall, lightR]} 89 | -- in error $ "\nN: " ++ show b2 ++ "\nR: " ++ show b2rot ++ "\nT: " ++ show b2trans 90 | in SceneVals { 91 | img_width = imageWidth, 92 | aspect_ratio = aspectRatio, 93 | img_height = imageHeight, 94 | nb_samples = 10, 95 | bounce_depth = 20, 96 | cam_look_from = cfrom, 97 | cam_look_to = cto, 98 | cam_vfov = cvfov, 99 | cam_vup = camVUp, 100 | cam_focus_distance = camFocDistance, 101 | cam_aperture = 0.0, 102 | scene_obj = hs, 103 | sample_obj = HList {objects = NList lightR []}, 104 | back_ground = PixSpecTrichroma(0.0, 0.0, 0.0) 105 | } 106 | -------------------------------------------------------------------------------- /src/Math3D/Quaternion.hs: -------------------------------------------------------------------------------- 1 | -- Basic Quaternion implementation 2 | module Math3D.Quaternion where 3 | 4 | import Math3D.Vector 5 | import Math3D.CommonOps 6 | 7 | data Quaternion = Quat {qR :: Double, qX :: Double, 8 | qY :: Double, qZ :: Double} deriving(Eq, Show) 9 | 10 | instance BinaryOps Quaternion where 11 | elementwiseOp _ f q1 q2 = 12 | let {q1r = qR q1; q2r = qR q2; q1x = qX q1; q2x = qX q2; 13 | q1y = qY q1; q2y = qY q2; q1z = qZ q1; q2z = qZ q2 14 | } 15 | in Quat {qR = f q1r q2r, qX = f q1x q2x, 16 | qY = f q1y q2y, qZ = f q1z q2z} 17 | elementwiseScalarOp _ f q = 18 | let {qr = qR q; qx = qX q; 19 | qy = qY q; qz = qZ q; 20 | } 21 | in Quat {qR = f qr, qX = f qx, 22 | qY = f qy, qZ = f qz} 23 | divide q1 q2 = 24 | let {q1r = qR q1; q2r = qR q2; q1x = qX q1; q2x = qX q2; 25 | q1y = qY q1; q2y = qY q2; q1z = qZ q1; q2z = qZ q2; 26 | q2rC = q2r == 0; q2xC = q2x == 0; q2yC = q2y == 0; 27 | q2zC = q2z == 0; anyZerosCheck = q2zC || q2xC || q2yC || q2rC; 28 | } 29 | in if anyZerosCheck 30 | then error "ZeroDivisionError :: performing zero division with quaternions" 31 | else Quat {qR = q1r / q2r, qX = q1x / q2x, 32 | qY = q1y / q2y, qZ = q1z / q2z} 33 | 34 | 35 | qVector :: Quaternion -> Vector 36 | qVector q = fromList2Vec (qX q) [qY q, qZ q] 37 | 38 | qScalar :: Quaternion -> Double 39 | qScalar q = qR q 40 | 41 | fromSVec2Quaternion :: Double -> Vector -> Quaternion 42 | fromSVec2Quaternion s v = 43 | if (vsize v) /= 3 44 | then error $ "vector size must be equal to 3: " ++ show (vsize v) 45 | else Quat {qR = s, qX = vget v 0, qY = vget v 1, qZ = vget v 2} 46 | 47 | {- From 48 | Nitecki, Z. (2018) Calculus in 3D: geometry, vectors, and multivariate 49 | calculus, section 8.5.2 50 | -} 51 | fromAngleAxis2Quaternion :: Double -> Vector -> Quaternion 52 | fromAngleAxis2Quaternion theta normal = 53 | let vnorm = vsize normal 54 | in if vnorm > 3 55 | then error "Vector must have 3 dimensions to be used as axis in 3d" 56 | else let costheta = cos $ theta / 2.0 57 | sintheta = sin $ theta / 2.0 58 | nsin = multiplyS normal sintheta 59 | in fromSVec2Quaternion costheta nsin 60 | 61 | hamiltonProduct :: Quaternion -> Quaternion -> Quaternion 62 | hamiltonProduct q_a q_b = 63 | let s_a = qScalar q_a 64 | s_b = qScalar q_b 65 | v_a = qVector q_a 66 | v_b = qVector q_b 67 | -- s_a * s_b 68 | sab = s_a * s_b 69 | -- va_dot_vb 70 | a_dot_b = dot v_a v_b 71 | -- va_cross_vb 72 | a_cross_b = cross3d v_a v_b 73 | -- s_a * b + s_b * a + va_cross_vb 74 | s_a_b = multiplyS v_b s_a 75 | s_b_a = multiplyS v_a s_b 76 | a_plus_b = add s_a_b s_b_a 77 | ab_plus_cross = add a_plus_b a_cross_b 78 | -- 79 | sab_minus_adotb = sab - a_dot_b 80 | (x:y:z:_) = vec2List $! ab_plus_cross 81 | in Quat {qR = sab_minus_adotb, qX = x, qY = y, qZ = z} 82 | 83 | 84 | qConjugate :: Quaternion -> Quaternion 85 | qConjugate q = multiplyS q (-1.0) 86 | 87 | qDeterminant :: Quaternion -> Double 88 | qDeterminant q = 89 | let Quat {qR = a2, qX = b2, qY = c2, qZ = d2} = multiply q q 90 | in a2 + b2 + c2 + d2 91 | 92 | qMagnitude :: Quaternion -> Double 93 | qMagnitude o = sqrt $ qDeterminant o 94 | 95 | toUnit :: Quaternion -> Quaternion 96 | toUnit q = 97 | let norm = qMagnitude q 98 | invmag = 1.0 / norm 99 | in multiplyS q invmag 100 | 101 | qInverse :: Quaternion -> Quaternion 102 | qInverse q = 103 | let invmag = 1.0 / (qMagnitude q) 104 | conj = qConjugate q 105 | sp = qScalar conj * invmag 106 | qv = multiplyS (qVector q) invmag 107 | in fromSVec2Quaternion sp qv 108 | -------------------------------------------------------------------------------- /src/Scene/SpectralScene.hs: -------------------------------------------------------------------------------- 1 | -- Spectral Checker scene 2 | module Scene.SpectralScene(cornellBoxSpectral) where 3 | 4 | -- scene default values 5 | import Scene.Scene 6 | 7 | import Color.ColorInterface 8 | import Color.Pixel 9 | 10 | -- spectral 11 | import Spectral.SampledSpectrum 12 | -- 13 | import System.Random 14 | import Random 15 | 16 | -- math 17 | import Math3D.Vector 18 | import Math3D.Ray 19 | 20 | -- texture 21 | import Texture.SolidColor 22 | import Texture.TextureObj 23 | import Texture.Spectral 24 | 25 | -- hittable 26 | import Hittable.HittableList 27 | import Hittable.HittableObj 28 | import Hittable.Hittable 29 | import Hittable.AaRect 30 | import Hittable.Rotatable 31 | import Hittable.Translatable 32 | 33 | -- instance 34 | import Instance.Box 35 | 36 | -- 37 | import Camera 38 | import Material.Material 39 | 40 | -- 41 | import Utility.HelperTypes 42 | 43 | cornellBoxSpectral :: RandomGen g => g -> Scene 44 | cornellBoxSpectral gen = 45 | let cfrom = fromList2Vec 278.0 [ 278.0, -800.0] 46 | cto = fromList2Vec 278.0 [ 278.0, 0.0] 47 | cvfov = 40.0 48 | -- set up camera 49 | sceneC = mkCamTime cfrom cto camVUp cvfov aspectRatio 0.0 camFocDistance 50 | whiteTexture = TextureCons (SpectT $! fromRGBModel 1.0 1.0 1.0 REFLECTANCE) 51 | redTexture = TextureCons (SpectT $! fromRGBModel 1.0 0.1 0.1 REFLECTANCE) 52 | greenTexture = TextureCons (SpectT $! fromRGBModel 0.1 1.0 0.1 REFLECTANCE) 53 | highWhiteTexture = TextureCons (SpectT $! fromRGBModel 15.0 15.0 15.0 ILLUMINANT) 54 | 55 | whiteMat = LambMat $! LambT whiteTexture 56 | redMat = LambMat $! LambT redTexture 57 | greenMat = LambMat $! LambT greenTexture 58 | lightMat = LightMat $! DLightEmitTextureCons highWhiteTexture 59 | -- cornell walls 60 | c1 = 0.0 61 | c2 = 555.0 62 | -- yz walls 63 | yzGreenWall = HittableCons $ mkYzRect c1 c2 c1 c2 c2 greenMat 64 | yzRedWall = HittableCons $ mkYzRect c1 c2 c1 c2 c1 redMat 65 | -- xz walls 66 | xzWhiteWall1 = HittableCons $ mkXzRect c1 c2 c1 c2 c2 whiteMat 67 | xzWhiteWall2 = HittableCons $ mkXzRect c1 c2 c1 c2 c1 whiteMat 68 | -- xy wall 69 | xyWhiteWall = HittableCons $ mkXyRect c1 c2 c1 c2 c2 whiteMat 70 | -- light 71 | lightR = HittableCons $ mkXzRect 213.0 343.0 227.0 332.0 554.0 lightMat 72 | 73 | -- boxes 74 | -- get locating parameters 75 | loc = getCameraLocatingParams gen sceneC 76 | (_, _, time) = loc 77 | b1 = mkBox (zeroV3) (fromList2Vec 165.0 [ 330.0, 165.0]) whiteMat 78 | b1rot = mkRotatable b1 45.0 RY (show b1) 79 | b1off = fromList2Vec 265.0 [0.0, 295.0] 80 | b1trans = HittableCons $! Translate b1rot b1off (show b1rot) 81 | b2 = mkBox (zeroV3) (fromList2Vec 165.0 [ 165.0, 165.0]) whiteMat 82 | b2rot = mkRotatable b2 (-18.0) RY (show b2) 83 | b2off = fromList2Vec 130.0 [0.0, 65.0] 84 | b2trans = HittableCons $! Translate b2rot b2off (show b2rot) 85 | 86 | hs = HList {objects = NList (b1trans) [b2trans, yzGreenWall, yzRedWall, 87 | xzWhiteWall1, xzWhiteWall2, 88 | xyWhiteWall, lightR]} 89 | -- in error $ "\nN: " ++ show b2 ++ "\nR: " ++ show b2rot ++ "\nT: " ++ show b2trans 90 | in SceneVals { 91 | img_width = imageWidth, 92 | aspect_ratio = aspectRatio, 93 | img_height = imageHeight, 94 | nb_samples = 5, 95 | bounce_depth = 5, 96 | cam_look_from = cfrom, 97 | cam_look_to = cto, 98 | cam_vfov = cvfov, 99 | cam_vup = camVUp, 100 | cam_focus_distance = camFocDistance, 101 | cam_aperture = 0.0, 102 | scene_obj = hs, 103 | sample_obj = HList {objects = NList lightR []}, 104 | back_ground = PixSpecSampled $! fromRGBModel 0.0 0.0 0.0 REFLECTANCE 105 | } 106 | -------------------------------------------------------------------------------- /src/Scene/CornellSphere.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- cornell box 3 | module Scene.CornellSphere(cornellSphere) where 4 | 5 | -- scene default values 6 | import Scene.Scene 7 | 8 | import Color.Pixel 9 | -- 10 | import System.Random 11 | import Random 12 | 13 | -- math 14 | import Math3D.Vector 15 | import Math3D.Ray 16 | 17 | -- texture 18 | import Texture.SolidColor 19 | import Texture.TextureObj 20 | 21 | -- hittable 22 | import Hittable.HittableList 23 | import Hittable.HittableObj 24 | import Hittable.Sphere 25 | import Hittable.Hittable 26 | import Hittable.AaRect 27 | import Hittable.Rotatable 28 | import Hittable.Translatable 29 | 30 | -- instance 31 | import Instance.Box 32 | 33 | -- 34 | import Camera 35 | import Material.Material 36 | 37 | -- 38 | import Utility.HelperTypes 39 | 40 | cornellSphere :: RandomGen g => g -> Scene 41 | cornellSphere gen = 42 | let cfrom = fromList2Vec 278.0 [ 278.0, -800.0] 43 | cto = fromList2Vec 278.0 [ 278.0, 0.0] 44 | cvfov = 40.0 45 | -- set up camera 46 | sceneC = mkCamTime cfrom cto camVUp cvfov aspectRatio 0.0 camFocDistance 47 | 48 | whitishTexture = TextureCons $! SolidD 0.75 0.8 0.6 49 | whiteTexture = TextureCons $! SolidD 0.75 0.75 0.75 50 | redTexture = TextureCons $! SolidD 0.65 0.05 0.05 51 | greenTexture = TextureCons $! SolidD 0.12 0.45 0.15 52 | highWhiteTexture = TextureCons $! SolidD 15.0 15.0 15.0 53 | blackTexture = TextureCons $! SolidD 0.0 0.0 0.0 54 | 55 | whiteMat = LambMat $! LambT whiteTexture 56 | redMat = LambMat $! LambT redTexture 57 | greenMat = LambMat $! LambT greenTexture 58 | lightMat = LightMat $! DLightEmitTextureCons highWhiteTexture 59 | metMat = MetalMat $! MetT whitishTexture 0.001 60 | dieMt = DielMat $! DielRefIndices [1.5] 61 | 62 | -- cornell walls 63 | c1 = 0.0 64 | c2 = 555.0 65 | -- yz walls 66 | yzGreenWall = HittableCons $ mkYzRect c1 c2 c1 c2 c2 greenMat 67 | yzRedWall = HittableCons $ mkYzRect c1 c2 c1 c2 c1 redMat 68 | -- xz walls 69 | xzWhiteWall1 = HittableCons $ mkXzRect c1 c2 c1 c2 c2 whiteMat 70 | xzWhiteWall2 = HittableCons $ mkXzRect c1 c2 c1 c2 c1 whiteMat 71 | -- xy wall 72 | xyWhiteWall = HittableCons $ mkXyRect c1 c2 c1 c2 c2 whiteMat 73 | -- light 74 | lightR = HittableCons $ mkXzRect 213.0 343.0 227.0 332.0 554.0 lightMat 75 | 76 | -- boxes 77 | -- get locating parameters 78 | loc = getCameraLocatingParams gen sceneC 79 | (_, _, time) = loc 80 | b1 = mkBox (zeroV3) (fromList2Vec 165.0 [ 330.0, 165.0]) metMat 81 | b1rot = mkRotatable b1 (-45.0) RY (show b1) 82 | b1off = fromList2Vec 265.0 [ 0.0, 295.0] 83 | b1trans = HittableCons $! Translate b1rot b1off (show b1) 84 | b2 = HittableCons $! SphereObj {sphereCenter = fromList2Vec 190.0 [ 90.0, 190.0], 85 | sphereRadius = 90.0, 86 | sphereMat = dieMt} 87 | 88 | hs = HList {objects = NList (b1trans) [b2, yzGreenWall, yzRedWall, 89 | xzWhiteWall1, xzWhiteWall2, 90 | xyWhiteWall, lightR]} 91 | -- in error $ "\nN: " ++ show b2 ++ "\nR: " ++ show b2rot ++ "\nT: " ++ show b2trans 92 | in SceneVals { 93 | img_width = imageWidth, 94 | aspect_ratio = aspectRatio, 95 | img_height = imageHeight, 96 | nb_samples = 100, 97 | bounce_depth = 20, 98 | cam_look_from = cfrom, 99 | cam_look_to = cto, 100 | cam_vfov = cvfov, 101 | cam_vup = camVUp, 102 | cam_focus_distance = camFocDistance, 103 | cam_aperture = 0.0, 104 | scene_obj = hs, 105 | sample_obj = HList {objects = NList lightR [b2, b1trans]}, 106 | back_ground = PixSpecTrichroma (0.0, 0.0, 0.0) 107 | } 108 | -------------------------------------------------------------------------------- /src/Hittable/ConstantMedium.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- constant medium module 4 | module Hittable.ConstantMedium where 5 | 6 | -- math 7 | import Math3D.Vector 8 | import Math3D.CommonOps 9 | import Math3D.Ray 10 | 11 | -- hittable 12 | import Hittable.Hittable 13 | import Hittable.HitRecord 14 | import Hittable.Aabb 15 | 16 | -- material 17 | import Material.Material 18 | 19 | -- texture 20 | import Texture.Texture 21 | import Texture.TextureObj 22 | 23 | -- utility 24 | import Utility.Utils 25 | 26 | -- other stuff 27 | import Prelude hiding(subtract) 28 | import Random 29 | 30 | data ConstantMedium where 31 | ConsMedium :: (Eq a, Show a, Hittable a) => a -> Material -> Double -> ConstantMedium 32 | 33 | instance Eq ConstantMedium where 34 | a == b = 35 | case a of 36 | (ConsMedium a1 _ d1) -> 37 | case b of 38 | (ConsMedium a1 _ d2) -> a1 == a1 && (d1 == d2) 39 | 40 | instance Show ConstantMedium where 41 | show a = 42 | case a of 43 | (ConsMedium boundary _ d) -> 44 | let msg1 = "" 46 | in msg1 ++ msg2 47 | 48 | -- 49 | mkConstantMedium :: (Eq a, Show a, Hittable a, Texture b) => a -> Double -> b -> ConstantMedium 50 | mkConstantMedium !boundary !density !tex = 51 | ConsMedium boundary (IsotMat $ IsotTexture (TextureCons tex)) ((-1.0) / density) 52 | 53 | instance Hittable ConstantMedium where 54 | {-# INLINE hit #-} 55 | boundingBox !a !tmn !tmx !ab = 56 | case a of 57 | (ConsMedium boundary _ _) -> boundingBox boundary tmn tmx ab 58 | 59 | -- hit function 60 | hit !a g !r !tmin !tmax !hrec = 61 | case a of 62 | (ConsMedium boundary mat invNegDensity) -> 63 | let (rec1, rec2) = (emptyRec, emptyRec) 64 | (nrec1, isFirstHit, g1) = hit boundary g r (-infty) infty rec1 65 | in if not isFirstHit 66 | then (hrec, False, g1) 67 | else let (nrec2, isSecHit, g2) = hit boundary g1 r ((hdist nrec1) + 0.0001) infty rec2 68 | in if not isSecHit 69 | then (hrec, False, g2) -- or (nrec1, False) ?? 70 | else let t_mn = if (hdist nrec1) < tmin 71 | then tmin 72 | else hdist nrec1 73 | t_min = if t_mn < 0 74 | then 0.0 75 | else t_mn 76 | t_max = if (hdist nrec2) > tmax 77 | then tmax 78 | else hdist nrec2 79 | rlength = magnitude $ direction r 80 | segmentLength = (t_max - t_min) * rlength 81 | RandResult (rval, g3) = randval g2 82 | hitDist = invNegDensity * (log rval) 83 | in if hitDist > segmentLength 84 | then (hrec, False, g3) 85 | else let RandResult (hnorm, g4) = randomUnitVector g3 86 | in (HRec { 87 | hdist = t_min + hitDist / rlength, 88 | point = at r t_min, 89 | pnormal = hnorm, 90 | matPtr = mat, 91 | isFront = True, -- arbitrary 92 | hUV_u = hUV_u nrec1, 93 | hUV_v = hUV_v nrec1 94 | } , 95 | True, g4) 96 | 97 | pdf_value _ g _ _ = RandResult (0.0, g) 98 | hrandom _ g _ = randomVec (0.0, 1.0) g 99 | -------------------------------------------------------------------------------- /src/Random.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- random related 4 | module Random where 5 | 6 | import System.Random 7 | import GHC.Float 8 | import Data.Functor 9 | 10 | -- utility functions 11 | import Utility.HelperTypes 12 | import Utility.BaseEnum 13 | 14 | 15 | data RandomResult a g where 16 | RandResult :: RandomGen g => (a, g) -> RandomResult a g 17 | 18 | 19 | randomFn :: (Random a, Ord a, RandomGen g) => g -> (a, a) -> RandomResult a g 20 | randomFn gen (!low, !high) = if low > high 21 | then ranD high low 22 | else ranD low high 23 | where ranD lval hval = 24 | let (a, g) = randomR (lval, hval) gen in RandResult (a, g) 25 | 26 | 27 | rfmap :: RandomGen g => (a -> b) -> RandomResult a g -> RandomResult b g 28 | rfmap f a = case a of 29 | (RandResult (b, g)) -> RandResult (f b, g) 30 | 31 | {- 32 | given a random result and a function that makes random result from two-tuple 33 | and a two-tuple make a random result 34 | -} 35 | randomChain :: (Ord a, RandomGen g) => RandomResult a g -> (g -> (a, a) -> RandomResult a g) -> (a, a) -> RandomResult a g 36 | 37 | randomChain res rf mnmx = case res of 38 | RandResult (_, g) -> rf g mnmx 39 | 40 | liftRandVal :: RandomGen g => RandomResult a g -> a 41 | liftRandVal a = case a of 42 | RandResult (b, _) -> b 43 | liftRandGen :: RandomGen g => RandomResult a g -> g 44 | liftRandGen a = case a of 45 | RandResult (_, b) -> b 46 | 47 | randFoldl :: RandomGen g => g -> NonEmptyList (g -> (a, a) -> RandomResult a g, (a, a)) -> RandomResult (NonEmptyList a) g 48 | randFoldl gen foldableFns = 49 | let foldfn acc fn = let (lst, g) = acc 50 | (f, (mn, mx)) = fn 51 | RandResult (b, g2) = f g (mn, mx) 52 | in (lst ++ [b], g2) 53 | (m:ms, g) = foldl foldfn ([], gen) (nl2List foldableFns) 54 | in RandResult (fromList2NL m ms, g) 55 | 56 | randFoldlFixedRange :: RandomGen g => g -> (a, a) -> NonEmptyList (g -> (a, a) -> RandomResult a g) -> RandomResult (NonEmptyList a) g 57 | 58 | randFoldlFixedRange gen r foldableFns = 59 | let foldfn acc fn = let (lst, g) = acc 60 | RandResult (b, g2) = fn g r 61 | in (lst ++ [b], g2) 62 | (m:ms, g) = foldl foldfn ([], gen) (nl2List foldableFns) 63 | in RandResult (fromList2NL m ms, g) 64 | 65 | 66 | randFoldlFixedRange2 :: RandomGen g => g -> NonEmptyList (g -> RandomResult a g) -> RandomResult (NonEmptyList a) g 67 | 68 | randFoldlFixedRange2 gen foldableFns = 69 | let foldfn acc fn = let (lst, g) = acc 70 | RandResult (b, g2) = fn g 71 | in (lst ++ [b], g2) 72 | (m:ms, g) = foldl foldfn ([], gen) (nl2List foldableFns) 73 | in RandResult (fromList2NL m ms, g) 74 | 75 | 76 | randMap :: (Ord a, RandomGen g) => g -> (g -> (a, a) -> RandomResult a g) -> NonEmptyList (a,a) -> RandomResult (NonEmptyList a) g 77 | 78 | randMap gen f ranges = 79 | let rs = nl2List ranges 80 | fn acc r = let (alst, g) = acc 81 | rval = f g r 82 | in case rval of 83 | (RandResult (b, g2)) -> (alst ++ [b], g2) 84 | (vals, g2) = foldl fn ([], gen) rs 85 | in RandResult (NList (head vals) (tail vals), g2) 86 | 87 | 88 | randomDouble :: RandomGen g => g -> (Double, Double) -> RandomResult Double g 89 | randomDouble = randomFn 90 | 91 | randomInt :: RandomGen g => g -> (Int, Int) -> RandomResult Int g 92 | randomInt = randomFn 93 | 94 | randomWord :: RandomGen g => g -> (Word, Word) -> RandomResult Word g 95 | randomWord = randomFn 96 | 97 | randomWaveVal :: RandomGen g => g -> (WaveVal, WaveVal) -> RandomResult WaveVal g 98 | randomWaveVal = randomFn 99 | 100 | randomPowerVal :: RandomGen g => g -> (PowerVal, PowerVal) -> RandomResult PowerVal g 101 | randomPowerVal = randomFn 102 | 103 | randval :: RandomGen g => g -> RandomResult Double g 104 | randval g = randomDouble g (0.0, 1.0) 105 | -------------------------------------------------------------------------------- /src/Scene/CornellSmoke.hs: -------------------------------------------------------------------------------- 1 | -- cornell smoke box 2 | module Scene.CornellSmoke(cornellSmoke) where 3 | 4 | -- scene default values 5 | import Scene.Scene 6 | 7 | import Color.ColorInterface 8 | import Color.Pixel 9 | -- 10 | import System.Random 11 | import Random 12 | 13 | -- math 14 | import Math3D.Vector 15 | import Math3D.Ray 16 | 17 | -- texture 18 | import Texture.SolidColor 19 | import Texture.TextureObj 20 | 21 | -- hittable 22 | import Hittable.HittableList 23 | import Hittable.HittableObj 24 | import Hittable.Hittable 25 | import Hittable.AaRect 26 | import Hittable.Rotatable 27 | import Hittable.Translatable 28 | import Hittable.ConstantMedium 29 | 30 | -- instance 31 | import Instance.Box 32 | 33 | -- 34 | import Camera 35 | import Material.Material 36 | 37 | -- 38 | import Utility.HelperTypes 39 | 40 | cornellSmoke :: RandomGen g => g -> Scene 41 | cornellSmoke gen = 42 | let cfrom = fromList2Vec 278.0 [ 278.0, -800.0] 43 | cto = fromList2Vec 278.0 [ 278.0, 0.0] 44 | cvfov = 40.0 45 | -- set up camera 46 | sceneC = mkCamTime cfrom cto camVUp cvfov aspectRatio 0.0 camFocDistance 47 | 48 | whitishTexture = TextureCons $! SolidD 0.75 0.3 0.6 49 | whiteTexture = TextureCons $! SolidD 0.75 0.75 0.75 50 | redTexture = TextureCons $! SolidD 0.65 0.05 0.05 51 | greenTexture = TextureCons $! SolidD 0.12 0.45 0.15 52 | highWhiteTexture = TextureCons $! SolidD 15.0 15.0 15.0 53 | blackTexture = TextureCons $! SolidD 0.0 0.0 0.0 54 | 55 | whiteMat = LambMat $! LambT whiteTexture 56 | redMat = LambMat $! LambT redTexture 57 | greenMat = LambMat $! LambT greenTexture 58 | lightMat = LightMat $! DLightEmitTextureCons highWhiteTexture 59 | 60 | -- cornell walls 61 | c1 = 0.0 62 | c2 = 555.0 63 | -- yz walls 64 | yzGreenWall = HittableCons $ mkYzRect c1 c2 c1 c2 c2 greenMat 65 | yzRedWall = HittableCons $ mkYzRect c1 c2 c1 c2 c1 redMat 66 | -- xz walls 67 | xzWhiteWall1 = HittableCons $ mkXzRect c1 c2 c1 c2 c2 whiteMat 68 | xzWhiteWall2 = HittableCons $ mkXzRect c1 c2 c1 c2 c1 whiteMat 69 | -- xy wall 70 | xyWhiteWall = HittableCons $ mkXyRect c1 c2 c1 c2 c2 whiteMat 71 | -- light 72 | lightR = HittableCons $ mkXzRect 213.0 343.0 227.0 332.0 554.0 lightMat 73 | 74 | -- boxes 75 | -- get locating parameters 76 | loc = getCameraLocatingParams gen sceneC 77 | (_, _, time) = loc 78 | b1 = mkBox (zeroV3) (fromList2Vec 165.0 [ 330.0, 165.0]) whiteMat 79 | b1rot = mkRotatable b1 45.0 RY (show b1) 80 | b1off = fromList2Vec 265.0 [ 0.0, 295.0] 81 | b1trans = Translate b1rot b1off (show b1rot) 82 | b2 = mkBox (zeroV3) (fromList2Vec 165.0 [ 165.0, 165.0]) whiteMat 83 | b2rot = mkRotatable b2 (-18.0) RY (show b2) 84 | b2off = fromList2Vec 130.0 [0.0, 65.0] 85 | b2trans = Translate b2rot b2off (show b2rot) 86 | b1smoke = mkConstantMedium b1trans 0.1 whitishTexture-- white 87 | b2smoke = mkConstantMedium b2trans 0.01 blackTexture -- black 88 | 89 | hs = HList {objects = NList (HittableCons b1smoke) [HittableCons $ b2smoke, 90 | yzGreenWall, yzRedWall, 91 | xzWhiteWall1, xzWhiteWall2, 92 | xyWhiteWall, lightR]} 93 | -- in error $ "\nN: " ++ show b2 ++ "\nR: " ++ show b2rot ++ "\nT: " ++ show b2trans 94 | in SceneVals { 95 | img_width = imageWidth, 96 | aspect_ratio = aspectRatio, 97 | img_height = imageHeight, 98 | nb_samples = 200, 99 | bounce_depth = 50, 100 | cam_look_from = cfrom, 101 | cam_look_to = cto, 102 | cam_vfov = cvfov, 103 | cam_vup = camVUp, 104 | cam_focus_distance = camFocDistance, 105 | cam_aperture = 0.0, 106 | scene_obj = hs, 107 | sample_obj = HList {objects = NList lightR []}, 108 | back_ground = PixSpecTrichroma (0.0, 0.0, 0.0) 109 | } 110 | -------------------------------------------------------------------------------- /src/Instance/Box.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- box instance for holding quads 3 | module Instance.Box where 4 | 5 | -- math3d 6 | import Math3D.Vector 7 | import Math3D.CommonOps 8 | import Math3D.Ray 9 | import Math3D.Transform 10 | 11 | import Hittable.AaRect 12 | import Hittable.Hittable 13 | import Hittable.HitRecord 14 | import Hittable.Aabb 15 | 16 | import Data.List 17 | import Data.Function 18 | 19 | import Material.Material 20 | import Utility.HelperTypes 21 | import Utility.Utils 22 | 23 | import Random 24 | 25 | import Prelude hiding(subtract) 26 | 27 | data Box = HBox { minBox :: Vector, maxBox :: Vector, 28 | boxMat :: Material, boxSides :: [AaRect] } 29 | 30 | mkBox :: Vector -> Vector -> Material -> Box 31 | mkBox mn mx mat = 32 | let mnx = vget mn 0 33 | mny = vget mn 1 34 | mnz = vget mn 2 35 | mxx = vget mx 0 36 | mxy = vget mx 1 37 | mxz = vget mx 2 38 | -- 39 | s1 = mkXyRect mnx mxx mny mxy mxz mat 40 | s2 = mkXyRect mnx mxx mny mxy mnz mat 41 | -- 42 | s3 = mkXzRect mnx mxx mnz mxz mny mat 43 | s4 = mkXzRect mnx mxx mnz mxz mxy mat 44 | -- 45 | s5 = mkYzRect mny mxy mnz mxz mnx mat 46 | s6 = mkYzRect mny mxy mnz mxz mxx mat 47 | in HBox {minBox = mn, maxBox = mx, boxMat = mat, 48 | boxSides = [s1,s2,s3,s4,s5,s6]} 49 | 50 | instance Eq Box where 51 | a == b = 52 | let HBox {minBox = amin, maxBox = amax, boxSides = as} = a 53 | HBox {minBox = bmin, maxBox = bmax, boxSides = bs} = b 54 | in amin == bmin && amax == bmax && as == bs 55 | 56 | instance Show Box where 57 | show (HBox {minBox = amin, maxBox = amax, boxSides = as}) = 58 | let msg = "" 60 | in msg ++ msg2 61 | 62 | instance Hittable Box where 63 | {-# INLINE hit #-} 64 | hit a g ry tmin tmax hrec = 65 | let (e:es) = boxSides a 66 | hitobjs = hits g tmax (e:es) hrec -- [(hrec, Bool, g)] 67 | in if null hitobjs 68 | then (hrec, False, g) 69 | else minimumBy (compare `on` hrecDist) hitobjs 70 | where hits _ _ [] _ = [] 71 | hits g1 mx (t:ts) hr = 72 | let (nhrec, isHit, g2) = hit t g1 ry tmin mx hr 73 | nhdist = hdist nhrec 74 | in if isHit 75 | then (nhrec, isHit, g2) : hits g2 nhdist ts nhrec 76 | else hits g2 mx ts hr 77 | hrecDist (a, _, _) = hdist a 78 | 79 | boundingBox !a !time0 !time1 !ab = 80 | let hs = boxSides a 81 | in if null hs 82 | then (ab, False) 83 | else let tempBox = zeroAabb3 84 | firstBox = True 85 | in bbox firstBox time0 time1 tempBox hs ab 86 | where bbox False t0 t1 tbox [] outBox = (outBox, True) 87 | bbox fbox t0 t1 tbox (htl:htls) outBox = 88 | let (sbox, hasBox) = boundingBox htl t0 t1 tbox 89 | in if hasBox == False 90 | then (tbox, False) 91 | else if fbox 92 | then bbox False t0 t1 sbox htls sbox 93 | else let obox = ssBox outBox sbox 94 | in bbox False t0 t1 sbox htls obox 95 | 96 | pdf_value a g orig v = 97 | let hr = emptyRec 98 | ry = Rd {origin = orig, direction = v, 99 | rtime = 0.0, wavelength = 0} 100 | (ahit, isHit, g1) = hit a g ry 0.001 (infty) hr 101 | in if not isHit 102 | then RandResult (0.0, g1) 103 | else let hp = point ahit 104 | rects = boxSides a 105 | compFn r = isPointInRect hp r 106 | sideIndex = findIndex compFn rects 107 | in case sideIndex of 108 | Nothing -> RandResult (0.0, g1) 109 | Just i -> let r = rects !! i 110 | in pdf_value r g1 orig v 111 | 112 | hrandom a g orig = let res = randomVector ((minBox a), (maxBox a)) g 113 | f rp = subtract rp orig 114 | in rfmap f res 115 | 116 | -------------------------------------------------------------------------------- /src/Scene/CornellImage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- cornell box 3 | module Scene.CornellImage(cornellBoxDemotic) where 4 | 5 | -- scene default values 6 | import Scene.Scene 7 | 8 | import Color.ColorInterface 9 | import Color.Pixel 10 | -- 11 | import System.Random 12 | import Random 13 | 14 | -- math 15 | import Math3D.Vector 16 | import Math3D.Ray 17 | 18 | -- texture 19 | import Texture.SolidColor 20 | import Texture.TextureObj 21 | import Texture.Image 22 | 23 | -- hittable 24 | import Hittable.HittableList 25 | import Hittable.HittableObj 26 | import Hittable.Hittable 27 | import Hittable.AaRect 28 | import Hittable.Rotatable 29 | import Hittable.Translatable 30 | import Hittable.Sphere 31 | 32 | -- instance 33 | import Instance.Box 34 | 35 | -- 36 | import Camera 37 | import Material.Material 38 | 39 | -- 40 | import Utility.HelperTypes 41 | 42 | 43 | import GHC.Float 44 | import Data.Bitmap.Base 45 | import Data.Bitmap.Simple 46 | 47 | cornellBoxDemotic :: RandomGen g => g -> Bitmap Word8 -> Scene 48 | cornellBoxDemotic gen !bmp = 49 | let cfrom = fromList2Vec 278.0 [ 278.0, -800.0] 50 | cto = fromList2Vec 278.0 [ 278.0, 0.0] 51 | cvfov = 40.0 52 | -- set up camera 53 | sceneC = mkCamTime cfrom cto camVUp cvfov aspectRatio 0.0 camFocDistance 54 | whitishTexture = TextureCons $! SolidD 0.75 0.8 0.6 55 | whiteTexture = TextureCons $! SolidD 0.75 0.75 0.75 56 | redTexture = TextureCons $! SolidD 0.65 0.05 0.05 57 | greenTexture = TextureCons $! SolidD 0.12 0.45 0.15 58 | highWhiteTexture = TextureCons $! SolidD 35.0 35.0 35.0 59 | imTex = TextureCons $! bitmapToImageT bmp 60 | 61 | whiteMat = LambMat $! LambT whiteTexture 62 | redMat = LambMat $! LambT redTexture 63 | greenMat = LambMat $! LambT greenTexture 64 | lightMat = LightMat $! DLightEmitTextureCons highWhiteTexture 65 | imgMat = LambMat $! LambT imTex 66 | dieMt = DielMat $! DielRefIndices [1.5] 67 | metMat = MetalMat $! MetT whitishTexture 0.001 68 | -- cornell walls 69 | c1 = 0.0 70 | c2 = 555.0 71 | -- yz walls 72 | yzGreenWall = HittableCons $ mkYzRect c1 c2 c1 c2 c2 imgMat 73 | yzRedWall = HittableCons $ mkYzRect c1 c2 c1 c2 c1 imgMat 74 | -- xz walls 75 | xzWhiteWall1 = HittableCons $ mkXzRect c1 c2 c1 c2 c2 imgMat 76 | xzWhiteWall2 = HittableCons $ mkXzRect c1 c2 c1 c2 c1 imgMat 77 | -- xy wall 78 | xyWhiteWall = HittableCons $ mkXyRect c1 c2 c1 c2 c2 imgMat 79 | -- light 80 | lightR = HittableCons $ mkXzRect 213.0 343.0 227.0 332.0 554.0 lightMat 81 | 82 | -- boxes 83 | -- get locating parameters 84 | loc = getCameraLocatingParams gen sceneC 85 | (_, _, time) = loc 86 | b1 = mkBox (zeroV3) (fromList2Vec 165.0 [ 330.0, 165.0]) metMat 87 | b1rot = mkRotatable b1 45.0 RY (show b1) 88 | b1off = fromList2Vec 265.0 [0.0, 295.0] 89 | b1trans = HittableCons $! Translate b1rot b1off (show b1rot) 90 | b2 = HittableCons $! SphereObj {sphereCenter = fromList2Vec 190.0 [ 90.0, 190.0], 91 | sphereRadius = 90.0, 92 | sphereMat = lightMat} 93 | b2rot = mkRotatable b2 (-18.0) RY (show b2) 94 | b2off = fromList2Vec 130.0 [0.0, 65.0] 95 | b2trans = HittableCons $! Translate b2rot b2off (show b2rot) 96 | 97 | hs = HList {objects = NList (b1trans) [b2trans, yzGreenWall, yzRedWall, 98 | xzWhiteWall1, xzWhiteWall2, 99 | xyWhiteWall, lightR]} 100 | -- in error $ "\nN: " ++ show b2 ++ "\nR: " ++ show b2rot ++ "\nT: " ++ show b2trans 101 | in SceneVals { 102 | img_width = 640, 103 | aspect_ratio = aspectRatio, 104 | img_height = getImgHeight 640 aspectRatio, 105 | nb_samples = 10, 106 | bounce_depth = 20, 107 | cam_look_from = cfrom, 108 | cam_look_to = cto, 109 | cam_vfov = cvfov, 110 | cam_vup = camVUp, 111 | cam_focus_distance = camFocDistance, 112 | cam_aperture = 0.0, 113 | scene_obj = hs, 114 | sample_obj = HList {objects = NList lightR []}, 115 | back_ground = PixSpecTrichroma(0.0, 0.0, 0.0) 116 | } 117 | -------------------------------------------------------------------------------- /src/Camera.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- camera module 3 | module Camera where 4 | 5 | -- math 6 | import Math3D.Vector 7 | import Math3D.CommonOps 8 | import Math3D.Ray 9 | import Math3D.Transform 10 | import Math3D.Onb 11 | 12 | 13 | -- spectral 14 | import Spectral.PbrtSpecdata 15 | 16 | import Utility.Utils 17 | import Utility.BaseEnum 18 | 19 | import Random 20 | 21 | -- thirdparty 22 | import Prelude hiding (subtract) 23 | import System.Random 24 | import GHC.Float 25 | 26 | 27 | data Camera = Cam { 28 | corigin :: Vector, 29 | lowerLeftCorner :: Vector, 30 | horizontal :: Vector, 31 | vertical :: Vector, 32 | camU :: Vector, 33 | camV :: Vector, 34 | camW :: Vector, 35 | lensRadius :: Double, 36 | time0 :: Double, 37 | time1 :: Double 38 | } deriving (Eq, Show) 39 | 40 | mkCam :: Vector -> Vector -> Vector -> Double -> Double -> Double -> Double -> Double -> Double -> Camera 41 | mkCam !lookFrom !lookAt !vup !vfov !aspect_ratio !aperture !focusDist !t0 !t1 = 42 | let theta = degrees_to_radians vfov 43 | h = tan (theta / 2.0) 44 | viewPortH = 2.0 * h 45 | viewPortW = aspect_ratio * viewPortH 46 | cw = toUnit $! subtract lookFrom lookAt 47 | cu = toUnit $! cross3d vup cw 48 | cv = cross3d cw cu 49 | cameraOrigin = lookFrom 50 | cameraH = multiplyS cu (focusDist * viewPortW) 51 | cameraV = multiplyS cv (focusDist * viewPortH) 52 | fDcw = multiplyS cw focusDist 53 | vhalf = divideS cameraV 2.0 54 | hhalf = divideS cameraH 2.0 55 | llC1 = subtract cameraOrigin hhalf 56 | llc2 = subtract llC1 vhalf 57 | llCorner = subtract llc2 fDcw 58 | in Cam { 59 | corigin = cameraOrigin, 60 | lowerLeftCorner = llCorner, 61 | horizontal = cameraH, 62 | vertical = cameraV, 63 | camU = cu, 64 | camW = cw, 65 | camV = cv, 66 | lensRadius = aperture / 2.0, 67 | time0 = t0, 68 | time1 = t1 69 | } 70 | 71 | mkCamTime :: Vector -> Vector -> Vector -> Double -> Double -> Double -> Double -> Camera 72 | mkCamTime lookFrom lookAt vup vfov aspect_ratio aperture focusDist = 73 | mkCam lookFrom lookAt vup vfov aspect_ratio aperture focusDist 0.0 0.0 74 | 75 | -- 76 | getCameraOnb :: Camera -> OrthoNormalBase 77 | getCameraOnb c = 78 | let w = camW c 79 | v = camV c 80 | u = camU c 81 | in onb3 w v u 82 | 83 | getCameraTime :: RandomGen g => g -> Camera -> Double 84 | getCameraTime gen c = 85 | let t0 = time0 c 86 | t1 = time1 c 87 | RandResult (res, _) = randomDouble gen (t0, t1) 88 | in res 89 | 90 | getCameraLocatingParams :: RandomGen g => g -> Camera -> LocatingParams 91 | getCameraLocatingParams g c = (corigin c, getCameraOnb c, getCameraTime g c) 92 | 93 | -- camera for listing 69 94 | lookF :: Vector 95 | lookF = fromList2Vec 13.0 [2.0, 3.0] 96 | lookT :: Vector 97 | lookT = fromList2Vec 0.0 [0.0, 0.0] 98 | vUp :: Vector 99 | vUp = fromList2Vec 0.0 [1.0, 0.0] 100 | 101 | mkCamera :: Camera 102 | mkCamera = 103 | mkCamTime 104 | lookF -- look from 105 | lookT -- look to 106 | vUp -- vup 107 | 20.0 -- vfov 108 | (3.0/2.0) -- aspect ratio 109 | 0.1 -- aperture 110 | 10.0 -- focus distance 111 | 112 | getRay :: RandomGen g => g -> Camera -> Double -> Double -> RandomResult Ray g 113 | getRay gen Cam {corigin = cameraOrigin, horizontal = cameraH, 114 | vertical = cameraV, lowerLeftCorner = llCorner, 115 | camU = cu, camW = cw, camV = cv, lensRadius = lr, 116 | time0 = t0, time1 = t1 117 | } s t = 118 | let RandResult (uvec, g) = randomUnitDisk gen 119 | rd = multiplyS uvec lr 120 | rdx = vget rd 0 121 | rdy = vget rd 1 122 | offset = add (multiplyS cu rdx) (multiplyS cv rdy) 123 | rorigin = add cameraOrigin offset 124 | rdir1 = add llCorner (multiplyS cameraH s) 125 | rdir2 = add rdir1 (multiplyS cameraV t) 126 | rdir3 = subtract rdir2 cameraOrigin 127 | rdir4 = subtract rdir3 offset 128 | RandResult (timeD, g2) = randomDouble g (t0, t1) 129 | lambdaStart = word2Float visibleWavelengthStart 130 | lambdaEnd = word2Float visibleWavelengthEnd 131 | RandResult (wlength, g3) = randomWaveVal g (lambdaStart, lambdaEnd) 132 | in RandResult (Rd {origin = rorigin, 133 | direction = rdir4, 134 | rtime = timeD, 135 | wavelength = wlength}, g3) 136 | -------------------------------------------------------------------------------- /src/Math3D/Transform.hs: -------------------------------------------------------------------------------- 1 | -- 3d transformations module 2 | module Math3D.Transform where 3 | 4 | import Math3D.Vector 5 | import Math3D.CommonOps 6 | import Math3D.Onb 7 | import Math3D.Quaternion 8 | import Math3D.Matrix 9 | import Utility.HelperTypes 10 | import Utility.Utils 11 | 12 | import Prelude hiding(add) 13 | 14 | 15 | type Origin = Vector 16 | type Point = Vector 17 | type Offset = Vector 18 | type LocatingParams = (Origin, OrthoNormalBase, Double) 19 | type AxisAngle = (Vector, Double) 20 | 21 | 22 | class Transformable a where 23 | transform :: a -> NonEmptyList Vector -> a 24 | 25 | locate :: Vector -> Origin -> OrthoNormalBase -> Vector 26 | locate avec origin onb = 27 | let lvec = localVec onb avec 28 | lorg = add origin lvec 29 | in lorg 30 | 31 | class Transformable a => Locatable a where 32 | localCoords :: a -> Double -> NonEmptyList Vector 33 | 34 | located :: a -> LocatingParams -> a 35 | located a (origin, onb, time) = 36 | let func v = locate v origin onb 37 | locs = mapNL func (localCoords a time) 38 | in transform a locs 39 | 40 | 41 | class (Show a, Locatable a, Transformable a) => Translatable a where 42 | translate :: a -> Offset -> Double -> a 43 | translate a offset time = 44 | let fnc vec = add vec offset 45 | nlocs = mapNL fnc (localCoords a time) 46 | in transform a nlocs 47 | 48 | 49 | class (Locatable a, Transformable a, Show a) => Rotatable a where 50 | rotate :: a -> LocatingParams -> Quaternion -> a 51 | {- 52 | Rotate a point with a quaternion, from: 53 | Vince, J. (2011) Quaternions for Computer Graphics. London: Springer London. 54 | q p q^{ -1 } 55 | -} 56 | rotate a (origin, onb, time) quat = 57 | let -- locs = [ locate v origin onb | v <- (toList $ localCoords a time) ] 58 | locs = localCoords a time 59 | rotatePoint point = 60 | let pquat = fromSVec2Quaternion 0.0 point 61 | qinv = qInverse quat 62 | in hamiltonProduct qinv (hamiltonProduct pquat quat) 63 | nlocs = mapNL qVector $! mapNL rotatePoint locs 64 | in transform a nlocs 65 | 66 | rotateMatAngle :: a -> Double -> Double -> Matrix -> a 67 | rotateMatAngle a angleDegree time rotmat = 68 | let 69 | locs = localCoords a time 70 | -- 3x1 vector 71 | toMatrix v = let (v1, v2, v3) = ((vget v 0), (vget v 1), (vget v 2)) 72 | in MList {mdata = fromList2NL v1 [v2, v3], mstride = 1} 73 | matList = mapNL toMatrix locs 74 | mmul m = matmul rotmat m 75 | rotatedCoords = mapNL mmul matList 76 | -- mat to vector 77 | toVector m = VList $ mdata m 78 | nlocs = mapNL toVector rotatedCoords 79 | nobj = transform a nlocs 80 | in nobj 81 | 82 | rotateXByAngle :: a -> Double -> Double -> a 83 | rotateXByAngle a angleDegree time = 84 | let theta = degrees_to_radians angleDegree 85 | matv1 = fromList2Vec 1.0 [0.0, 0.0] 86 | matv2 = fromList2Vec 0.0 [cos theta, -(sin theta)] 87 | matv3 = fromList2Vec 0.0 [sin theta, cos theta] 88 | rotmat = matFromVector (fromList2NL matv1 [matv2, matv3]) -- 3x3 matrix 89 | in rotateMatAngle a angleDegree time rotmat 90 | 91 | rotateYByAngle :: a -> Double -> Double -> a 92 | rotateYByAngle a angleDegree time = 93 | let theta = degrees_to_radians angleDegree 94 | matv1 = fromList2Vec (cos theta) [0.0, sin theta] 95 | matv2 = fromList2Vec 0.0 [1.0, 0.0] 96 | matv3 = fromList2Vec (-(sin theta)) [0.0, cos theta] 97 | rotmat = matFromVector (fromList2NL matv1 [matv2, matv3]) -- 3x3 matrix 98 | in rotateMatAngle a angleDegree time rotmat 99 | 100 | rotateZByAngle :: a -> Double -> Double -> a 101 | rotateZByAngle a angleDegree time = 102 | let theta = degrees_to_radians angleDegree 103 | matv1 = fromList2Vec (cos theta) [-(sin theta), 0.0] 104 | matv2 = fromList2Vec (sin theta) [cos theta, 0.0] 105 | matv3 = fromList2Vec 0.0 [0.0, 1.0] 106 | rotmat = matFromVector (fromList2NL matv1 [matv2, matv3]) -- 3x3 matrix 107 | in rotateMatAngle a angleDegree time rotmat 108 | 109 | 110 | class Scalable a where 111 | scale :: (Locatable a, Transformable a) => a -> Offset -> LocatingParams -> a 112 | scale a offset (origin, onb, time) = 113 | let locs = [locate v origin onb | v <- (nl2List $ localCoords a time)] 114 | (n:ns) = [multiply offset v | v <- locs] 115 | in transform a (fromList2NL n ns) 116 | -------------------------------------------------------------------------------- /src/Color/Pixel.hs: -------------------------------------------------------------------------------- 1 | -- pixel 2 | module Color.Pixel where 3 | 4 | import Math3D.Vector 5 | import Math3D.CommonOps 6 | 7 | import Color.ColorInterface 8 | 9 | -- 10 | import Spectral.SampledSpectrum 11 | import Spectral.SampledDistribution 12 | 13 | -- basic types and enumerations 14 | import Utility.BaseEnum 15 | 16 | -- 17 | import Debug.Trace 18 | 19 | data PixelSpectrum = PixSpecTrichroma (Double, Double, Double) 20 | | PixSpecSampled SampledSpectrum 21 | deriving (Eq, Show) 22 | 23 | zeroPixelSpectrum :: PixelSpectrum 24 | zeroPixelSpectrum = PixSpecTrichroma (0.0, 0.0, 0.0) 25 | 26 | pixelSpectrumData :: PixelSpectrum -> Vector 27 | pixelSpectrumData a = 28 | case a of 29 | PixSpecTrichroma (r, g, b) -> fromList2Vec r [g, b] 30 | PixSpecSampled s -> (powers . sampled) s 31 | 32 | pixelCheck :: PixelSpectrum -> PixelSpectrum -> (Bool, String) 33 | pixelCheck a c = 34 | case a of 35 | PixSpecTrichroma _ -> 36 | case c of 37 | PixSpecTrichroma _ -> (True, "Pixel is of same type") 38 | PixSpecSampled _ -> (False, "Pixel spectrums are not of same type") 39 | PixSpecSampled _ -> 40 | case c of 41 | PixSpecTrichroma _ -> (False, "Pixel spectrums are not of same type") 42 | PixSpecSampled _ -> (True, "Pixel is of same type") 43 | 44 | 45 | instance BinaryOps PixelSpectrum where 46 | elementwiseOp str f a b = 47 | let (isSame, s) = pixelCheck a b 48 | in if not isSame 49 | then traceStack (s ++ " :: " ++ str) zeroPixelSpectrum 50 | else case a of 51 | PixSpecTrichroma (r1, g1, b1) -> 52 | case b of 53 | PixSpecTrichroma (r2, g2, b2) -> 54 | let v1 = fromList2Vec r1 [g1, b1] 55 | v2 = fromList2Vec r2 [g2, b2] 56 | res = elementwiseOp str f v1 v2 57 | [rr, gg, bb] = vec2List $! res 58 | in PixSpecTrichroma (rr, gg, bb) 59 | PixSpecSampled _ -> 60 | traceStack (s ++ " :: " ++ str) zeroPixelSpectrum 61 | PixSpecSampled s1 -> 62 | case b of 63 | PixSpecTrichroma _ -> 64 | traceStack (s ++ " :: " ++ str) zeroPixelSpectrum 65 | PixSpecSampled s2 -> 66 | PixSpecSampled $! elementwiseOp str f s1 s2 67 | 68 | elementwiseScalarOp str f a = 69 | case a of 70 | PixSpecTrichroma (r, g, b) -> 71 | let res = elementwiseScalarOp str f (fromList2Vec r [g, b]) 72 | [rr, gg, bb] = vec2List $! res 73 | in PixSpecTrichroma (rr, gg, bb) 74 | PixSpecSampled s -> PixSpecSampled $! elementwiseScalarOp str f s 75 | 76 | -- division 77 | divide a b = 78 | let (isSame, str) = pixelCheck a b 79 | in if not isSame 80 | then traceStack str zeroPixelSpectrum 81 | else case a of 82 | PixSpecTrichroma (r1, g1, b1) -> 83 | case b of 84 | PixSpecTrichroma (r2, g2, b2) -> 85 | let v1 = fromList2Vec r1 [g1, b1] 86 | v2 = fromList2Vec r2 [g2, b2] 87 | res = divide v1 v2 88 | [rr, gg, bb] = vec2List $! res 89 | in PixSpecTrichroma (rr, gg, bb) 90 | PixSpecSampled _ -> 91 | traceStack str zeroPixelSpectrum 92 | PixSpecSampled s1 -> 93 | case b of 94 | PixSpecTrichroma _ -> 95 | traceStack str zeroPixelSpectrum 96 | PixSpecSampled s2 -> PixSpecSampled $! divide s1 s2 97 | 98 | 99 | toColorRecord :: PixelSpectrum -> WaveVal -> ColorRecord 100 | toColorRecord a wave = case a of 101 | PixSpecTrichroma (r,g,b) -> ColorRec { 102 | model = ColorRGB $! fromList2Vec r [g, b] 103 | } 104 | PixSpecSampled s -> 105 | let v = evaluateWave wave (sampled s) 106 | in ColorRec { 107 | model = ColorSpec (spectrumType s, (wave, v)) 108 | } 109 | 110 | data Pixel = Pix {x :: Int, y :: Int, 111 | color :: PixelSpectrum} deriving (Eq, Show) 112 | -------------------------------------------------------------------------------- /src/Texture/Image.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- image texture 3 | module Texture.Image where 4 | 5 | -- math related 6 | import Math3D.Vector 7 | import Math3D.CommonOps 8 | -- color related 9 | import Color.ColorInterface 10 | -- 11 | import Texture.Texture 12 | -- 13 | import Utility.Utils 14 | 15 | -- thirdparty 16 | import GHC.Float hiding (clamp) 17 | import Data.Word 18 | import Data.Bitmap.Pure.Pixels 19 | import Data.Bitmap.Base 20 | import Codec.Image.STB 21 | import qualified Data.Map as DMap 22 | import Data.List 23 | import Debug.Trace 24 | 25 | type Row = Int 26 | type Column = Int 27 | 28 | type ImageData = [[Word8]] 29 | 30 | data ImageT = ImgT { 31 | imgTWidth :: Int, 32 | imgTHeight :: Int, 33 | bytesPerScanline :: Int, 34 | bytesPerPixel :: Int, 35 | imgData :: ImageData 36 | } 37 | 38 | instance Show ImageT where 39 | show (ImgT {imgTWidth = a, imgTHeight = b, 40 | bytesPerScanline = c, 41 | bytesPerPixel = d, imgData = _}) = 42 | let msg1 = "" 44 | in msg1 ++ msg2 45 | 46 | 47 | debugImageT :: ImageT -> String 48 | debugImageT img = 49 | let imdata = imgData img 50 | msg1 = show img 51 | msg2 = show imdata 52 | in msg1 ++ " data: " ++ msg2 53 | 54 | -- 55 | pixToDouble :: Word8 -> Double 56 | pixToDouble p = fromRational $ toRational p 57 | 58 | bitmapToImageT :: Image -> ImageT 59 | bitmapToImageT !b = 60 | let (w, h) = bitmapSize b 61 | channels = bitmapNChannels b 62 | offsets = [(ww, hh) | hh <- [0..(h-1)], ww <- [0..(w-1)] ] 63 | readerFn oset = let p = unsafeReadPixel b oset 64 | in p 65 | -- foldfn :: (a -> b -> a) :: ([] -> [a] -> [a]) 66 | imdata = map (readerFn) offsets 67 | -- imindx = [0..((length imdata) - 1)] 68 | imgt = ImgT {imgTWidth = w, imgTHeight = h, 69 | bytesPerPixel = channels, 70 | bytesPerScanline = channels * w, 71 | imgData = imdata} 72 | in imgt 73 | -- in error $ debugImageT imgt 74 | 75 | 76 | instance Texture ImageT where 77 | color !imgt !u !v p _ = 78 | let (ImgT {imgTWidth = a, imgTHeight = b, bytesPerScanline = bps, 79 | bytesPerPixel = bpp, imgData = imap}) = imgt 80 | in if null imap 81 | then ColorRec { model = ColorRGB $! fromList2Vec 0.0 [1.0, 1.0] } 82 | else let uu = clamp u 0.0 1.0 83 | vv = 1.0 - (clamp v 0.0 1.0) 84 | -- vv = clamp v 0.0 1.0 85 | -- uu = 1.0 - (clamp u 0.0 1.0) 86 | i_ = double2Int $ uu * (int2Double a) 87 | j_ = double2Int $ vv * (int2Double b) 88 | -- 89 | i = if i_ >= a 90 | then a - 1 91 | else i_ 92 | j = if j_ >= b 93 | then b - 1 94 | else j_ 95 | cscale = 1.0 / 255.0 96 | pix = let cs = [0..(bpp-1)] 97 | coeff = (j * bps) + (i * bpp) 98 | iis = [coeff + c | c <- cs] 99 | -- vals = map pixToDouble [imap !! ii | ii <- iis] 100 | pixIndex = let pindex = j * a + i 101 | msg = "negative index row: " ++ show j 102 | msg2 = " image width " ++ show a 103 | msg3 = " image height " ++ show b 104 | msg4 = " column index " ++ show i 105 | msg5 = " uu " ++ show uu 106 | msg6 = " vv " ++ show vv 107 | msg7 = " u " ++ show u 108 | msg8 = " v " ++ show v 109 | msg9 = msg ++ msg2 ++ msg3 ++ msg4 110 | msg10 = msg5 ++ msg6 ++ msg7 111 | msg11 = msg8 ++ msg9 ++ msg10 112 | in if pindex < 0 113 | then traceStack msg11 0 114 | else pindex 115 | (val:vals) = map pixToDouble (imap !! pixIndex) 116 | -- in VList [imap DMap.! ii | ii <- iis] 117 | in fromList2Vec val vals 118 | cval = multiplyS pix cscale 119 | in ColorRec { model = ColorRGB cval } 120 | -- in error $ show imgt 121 | -------------------------------------------------------------------------------- /src/Hittable/Sphere.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- module for sphere objects 3 | module Hittable.Sphere where 4 | 5 | import Math3D.Vector 6 | import Math3D.CommonOps 7 | import Math3D.Ray 8 | import Math3D.Onb 9 | 10 | import Utility.Utils 11 | import Hittable.Hittable 12 | import Hittable.HitRecord 13 | import Hittable.Aabb 14 | import Prelude hiding(subtract) 15 | import Material.Material 16 | 17 | -- random 18 | import Random 19 | 20 | 21 | data Sphere = SphereObj {sphereCenter :: Vector, 22 | sphereRadius :: Double, 23 | sphereMat :: Material} 24 | 25 | getSphereUV :: Vector -> (Double, Double) 26 | getSphereUV v = 27 | let (x:y:z:_) = vec2List v 28 | theta = acos (-y) 29 | phi = (atan2 (-z) x) + m_pi 30 | in (phi / (2*m_pi), theta / m_pi) 31 | 32 | instance Eq Sphere where 33 | (SphereObj {sphereCenter = a, 34 | sphereRadius = b}) == (SphereObj {sphereCenter = c, 35 | sphereRadius = d}) = 36 | a == c && b == d 37 | 38 | instance Show Sphere where 39 | show (SphereObj {sphereCenter = a, sphereRadius = b}) = 40 | "Shpere with center: " ++ show a ++ " radius: " ++ show b 41 | 42 | 43 | instance Hittable Sphere where 44 | {-# INLINE hit #-} 45 | hit !(SphereObj {sphereCenter = sc, 46 | sphereRadius = sr, 47 | sphereMat = sm}) g !(Rd {origin = ro, 48 | direction = rd, 49 | rtime = rt, 50 | wavelength = rwave }) !tmin !tmax !hrec = 51 | let oc = subtract ro sc 52 | a = lengthSquared rd 53 | hb = dot oc rd 54 | c = (lengthSquared oc) - (sr * sr) 55 | discriminant = hb * hb - a * c 56 | ry = Rd {origin = ro, direction = rd, 57 | rtime = rt, wavelength = rwave} 58 | in if discriminant < 0 59 | then (hrec, False, g) 60 | else let sqd = sqrt discriminant 61 | root = (-hb - sqd) / a 62 | nroot = (-hb + sqd) / a 63 | cond1 = root < tmin || tmax < root 64 | cond2 = nroot < tmin || tmax < nroot 65 | result 66 | | cond1 && cond2 = (hrec, False, g) 67 | | cond1 && (not cond2) = 68 | let hpoint = at ry nroot 69 | hnorm = divideS (subtract hpoint sc) sr 70 | (hu, hv) = getSphereUV hnorm 71 | hr = HRec {hdist = nroot, point = hpoint, 72 | pnormal = hnorm, 73 | matPtr = sm, 74 | hUV_u = hu, 75 | hUV_v = hv, 76 | isFront = False} 77 | in (setFaceNormal hr ry hnorm, True, g) 78 | | otherwise = 79 | let hpoint = at ry root 80 | hnorm = divideS (subtract hpoint sc) sr 81 | (hu, hv) = getSphereUV hnorm 82 | hr = HRec {hdist = root, point = hpoint, 83 | pnormal = hnorm, matPtr = sm, 84 | hUV_u = hu, hUV_v = hv, 85 | isFront = False} 86 | in (setFaceNormal hr ry hnorm, True, g) 87 | in result 88 | 89 | boundingBox !(SphereObj {sphereCenter = sc, sphereRadius = sr, 90 | sphereMat = _}) !tmn !tmx !ab = 91 | let cv1 = subtract sc (fromList2Vec sr [sr, sr]) 92 | cv2 = add sc (fromList2Vec sr [sr, sr]) 93 | aBound = AaBbox { aabbMin = cv1, aabbMax = cv2 } 94 | in (aBound, True) 95 | 96 | pdf_value a g orig v = 97 | let hr = emptyRec 98 | ry = Rd {origin = orig, direction = v, 99 | rtime = 0.0, wavelength = 0} 100 | (ahit, isHit, g1) = hit a g ry 0.001 (infty) hr 101 | in if not isHit 102 | then RandResult (0.0, g1) 103 | else let cent = sphereCenter a 104 | corg = lengthSquared $! subtract cent orig 105 | radius = sphereRadius a 106 | radorg = (radius * radius) / corg 107 | costheta = sqrt $! 1.0 - radorg 108 | solidAngle = 2.0 * m_pi * (1.0 - costheta) 109 | in RandResult (1.0 / solidAngle, g1) 110 | 111 | hrandom a g orig = 112 | let cent = sphereCenter a 113 | dir = subtract cent orig 114 | distSqr = lengthSquared dir 115 | onb = fromW2Onb dir 116 | radius = sphereRadius a 117 | res = random2Sphere g (radius, distSqr) 118 | in rfmap (localVec onb) res 119 | 120 | -------------------------------------------------------------------------------- /src/Color/ColorInterface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- input output of colors 3 | module Color.ColorInterface where 4 | 5 | import Math3D.Vector 6 | import Math3D.CommonOps 7 | 8 | import Spectral.SampledSpectrum 9 | 10 | import Utility.BaseEnum 11 | 12 | -- thirdparty 13 | import Debug.Trace 14 | 15 | data ColorFlag = RGB 16 | | Spectral SpectrumType 17 | deriving (Show, Eq) 18 | 19 | data ColorModel = ColorRGB Vector 20 | | ColorSpec (SpectrumType, (WaveVal, PowerVal)) 21 | deriving (Show, Eq) 22 | 23 | data ColorRecord = ColorRec { model :: ColorModel } deriving (Eq, Show) 24 | 25 | emptyRGBRecord :: ColorRecord 26 | emptyRGBRecord = ColorRec { model = ColorRGB zeroV3 } 27 | 28 | stype :: ColorRecord -> ColorFlag 29 | stype a = case model a of 30 | ColorRGB _ -> RGB 31 | ColorSpec (b, _) -> Spectral b 32 | 33 | -- obtain color data: we upcast everything to vector 34 | colorData :: ColorRecord -> Vector 35 | colorData a = case model a of 36 | ColorRGB v -> v 37 | ColorSpec (_, (_,v)) -> fromList2Vec v [] 38 | 39 | emptyModelLike :: ColorRecord -> ColorRecord 40 | emptyModelLike a = case model a of 41 | ColorRGB v -> ColorRec {model = ColorRGB $! zeroLikeVector v} 42 | ColorSpec (s, (w, _)) -> ColorRec {model = ColorSpec (s, (w, 0.0)) } 43 | 44 | colorModelCheck :: ColorRecord -> ColorRecord -> (Bool, String) 45 | colorModelCheck a b = 46 | let sa = stype a 47 | sb = stype b 48 | isEqual = case sa of 49 | RGB -> case sb of 50 | RGB -> True 51 | _ -> False 52 | Spectral _ -> case sb of 53 | Spectral _ -> True 54 | _ -> False 55 | msg1 = "Color Models of interfaces are not the same: " 56 | msg2 = show (stype a) 57 | msg3 = show (stype b) 58 | in (isEqual, msg1 ++ msg2 ++ " " ++ msg3 ) 59 | 60 | wavelengthStr :: WaveVal -> WaveVal -> String 61 | wavelengthStr a b = 62 | let msg1 = "wavelengths are not same" 63 | msg2 = " for given spectral powers" 64 | msg3 = ", this library is not" 65 | msg4 = " equiped to cover such cases" 66 | msg5 = " for sampled spectrums." 67 | msg6 = msg1 ++ msg2 ++ msg3 ++ msg4 ++ msg5 68 | msg7 = msg6 ++ " First wavelength " ++ show a 69 | msg8 = msg7 ++ ", second wavelength " ++ show b 70 | in msg8 71 | 72 | 73 | instance BinaryOps ColorRecord where 74 | elementwiseOp str f a b = 75 | let (isSame, s) = colorModelCheck a b 76 | in if not isSame 77 | then traceStack (s ++ " :: " ++ str) (emptyModelLike a) 78 | else case model a of 79 | ColorRGB av -> 80 | case model b of 81 | ColorRGB bv -> 82 | ColorRec {model = ColorRGB $! vecArithmeticOp str f av bv} 83 | _ -> traceStack (s ++ " :: " ++ str) (emptyModelLike a) 84 | ColorSpec (sa, (aw, apower)) -> 85 | case model b of 86 | ColorSpec (sb, (bw, bpower)) -> 87 | if aw == bw 88 | then ColorRec { model = ColorSpec (sa, (aw, f apower bpower)) } 89 | else let msg = wavelengthStr aw bw 90 | in traceStack (msg ++ " " ++ str) (emptyModelLike a) 91 | _ -> traceStack (s ++ " :: " ++ str) (emptyModelLike a) 92 | 93 | elementwiseScalarOp str f a = 94 | case model a of 95 | ColorRGB av -> ColorRec {model = ColorRGB $! vecScalarOp f av} 96 | ColorSpec (s, (aw, p)) -> ColorRec {model = ColorSpec (s, (aw, f p))} 97 | 98 | -- division 99 | divide a b = 100 | let (isSame, str) = colorModelCheck a b 101 | in if not isSame 102 | then traceStack str (emptyModelLike a) 103 | else case model a of 104 | ColorRGB av -> 105 | case model b of 106 | ColorRGB bv -> 107 | ColorRec {model = ColorRGB $! divide av bv } 108 | _ -> traceStack str (emptyModelLike a) 109 | ColorSpec (sa, (aw, apower)) -> 110 | case model b of 111 | ColorSpec (sb, (bw, bpower)) -> 112 | if aw == bw 113 | then if bpower /= 0.0 114 | then ColorRec {model = ColorSpec (sa, (aw, apower / bpower)) } 115 | else traceStack 116 | "zero division in color models" 117 | (emptyModelLike a) 118 | else let msg = wavelengthStr aw bw 119 | in traceStack msg (emptyModelLike a) 120 | _ -> traceStack str (emptyModelLike a) 121 | 122 | 123 | fromRGB :: Double -> Double -> Double -> ColorRecord 124 | fromRGB a b c = ColorRec { model = ColorRGB $! fromList2Vec a [b, c] } 125 | 126 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rt-haskell 2 | 3 | A Path Tracer in Haskell 4 | 5 | We follow mostly the P. Shirley's architecture with couple of differences. 6 | 7 | The branches follow the chapters from [online](raytracing.github.io/) 8 | repository. 9 | 10 | 11 | ## Show case 12 | 13 | - Small color gradient in 01-ppm branch: 14 | 15 | ![ppm-color-gradient](./images/gradient.png) 16 | 17 | 18 | - Red sphere from 04-sphere branch: 19 | 20 | ![red-sphere](./images/sphere.png) 21 | 22 | - Normals from branch 05-surface: 23 | 24 | ![surface-normals](./images/05-surface.png) 25 | 26 | - Multiple objects from branch 06-multiple: 27 | 28 | ![multiple-normals](./images/multiple.png) 29 | 30 | - Antialiasing from branch 07-antialias: 31 | 32 | ![antialias-normals](./images/antialias.png) 33 | 34 | - Diffuse image from branch 08-diffuse 35 | 36 | ![diffuse-image](./images/diffuse.png) 37 | 38 | - Metal image from branch 09-metal 39 | 40 | ![metal-image-01](./images/metal.png) 41 | 42 | - Fuzzy metal image from branch 09-metal 43 | 44 | ![metal-image-02](./images/fuzzmetal.png) 45 | 46 | - Dielectric from branch 10-dielectric 47 | 48 | ![dielectric-01](./images/diel01.png) 49 | 50 | - Camera focus from branch 11-camera 51 | 52 | ![focus-image-02](./images/focus.png) 53 | 54 | - A version of final scene from branch 12-oneweekend 55 | 56 | ![oneweekend-final-image-01](./images/final-oneweekend-diffuse.png) 57 | 58 | - Another version of final scene branch 12-oneweekend 59 | 60 | ![oneweekend-final-image-02](./images/final-oneweekend-metallic.png) 61 | 62 | - Fixed version of final scene. The fix happens around branch 14-texture 63 | 64 | ![oneweekend-final-image-03](./images/oneweekendfinal.png) 65 | 66 | - Final one weekend final branch 14-texture 67 | 68 | ![oneweekend-final-image-04](./images/oneweekend.png) 69 | 70 | - Motion blur branch 14-texture 71 | 72 | ![motion-blur-image-01](./images/motionblur.png) 73 | 74 | - Checkered texture from branch 14-texture 75 | 76 | ![checker-image-01](./images/checker.png) 77 | 78 | - Perlin Noise with Light from branch 14-texture 79 | 80 | ![perlin-image-01](./images/light.png) 81 | 82 | - Earth image from branch 14-texture 83 | 84 | ![earth-image-01](./images/earth.png) 85 | 86 | - Cornell box image from branch 15-instances 87 | 88 | ![cornell-box-01](./images/cornell.png) 89 | 90 | - Cornell smoke boxes from branch 16-constant-density-mediums 91 | 92 | ![cornell-box-02](./images/smoke.png) 93 | 94 | - Cornell sphere and a box from branch 17-scattering-pdf 95 | 96 | ![cornell-box-03](./images/cornellFinal.png) 97 | 98 | - Cornell box from 18-spectral 99 | 100 | ![cornell-box-04](./images/spectral.png) 101 | 102 | 103 | 104 | ## Some Notes 105 | 106 | ### RNGs and performance 107 | 108 | The from branch 08-diffuse an onwards as the usage of random functions become 109 | prominent the performance decreases considerably. However the inverse is also 110 | true, if you can place your random generators efficiently, you can easily 111 | increase your performance. I simply concentrated on getting the images right. 112 | Do not be surprised if you find that some other arrangement of RNGs result in 113 | better performance. 114 | 115 | 116 | ### Spectral Rendering 117 | 118 | Spectral rendering is done through use of spectral textures. The general idea 119 | is that material determines the behaviour of the surface distribution function 120 | and the texture determines its color space. 121 | You can see how spectral textures are used in `SpectralScene.hs`. The 122 | rendering function determines that the scene is spectral using the data type 123 | of the background. If the background is of type `PixSpecSampled` then it 124 | switches to spectral rendering. 125 | 126 | Another point is the setting spectral data from rgb color model. This done 127 | through the convenience function `fromRGBModel`. You can try specifying 128 | spectrum data directly as well. A `SampledSpectrum` is simply a non empty list 129 | of wavelength, power tuple along with a spectrum type specifier. This last 130 | call is not entirely necessary, since for all the operations between spectrums 131 | we don't care about the type of the spectrum, but it becomes convenient to 132 | know when you are doing conversions between spectrum to trichromatic systems. 133 | 134 | Lastly the beware that spectral rendering takes much more time than its rgb 135 | equivalent. The spectral cornell box whose image can be found in the 136 | 18-spectral branch took `3931.857353s` with 5 samples per pixel and 5 ray 137 | bounce limit for an image width 320 and aspect ratio 16:9. The sampled 138 | wavelength range is `[380, 720]`, and the sampling step size is 5, so we sampled 139 | power values for a list of wavelengths such as `[380, 385, ..., 720]`. 140 | 141 | ### Rotations 142 | 143 | We use a slightly more flexible approach to rotations than the original books. 144 | Basically the rotation is done using rotation matrices which are constructed 145 | from the angle and axis information provided during the setup of Rotatable 146 | type. Though it can be generalized into arbitrary axis, we are currently 147 | supporting only XYZ axes which are passed as RotationAxis type. Also our 148 | rotations are inversed with respect to the book. That which is in clockwise is 149 | counter clockwise in our case. 150 | 151 | ## Planned Features 152 | 153 | I hope to make the tracer as minimal but useful as possible. 154 | Here is a list of planned features: 155 | 156 | - Loading assets with obj files 157 | - Spectral rendering switch: done 158 | - BVH acceleration structure: done but not tested. 159 | - Multithreaded rendering: This is as easy as passing -N3 as option now, since 160 | most of the code is composed of pure functions. 161 | -------------------------------------------------------------------------------- /src/Hittable/MovingSphere.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- moving sphere module 3 | module Hittable.MovingSphere where 4 | 5 | -- math 6 | import Math3D.Ray 7 | import Math3D.Vector 8 | import Math3D.CommonOps 9 | import Math3D.Onb 10 | 11 | -- hittable 12 | import Hittable.Hittable 13 | import Hittable.HitRecord 14 | import Hittable.Aabb 15 | 16 | -- random 17 | import Random 18 | 19 | -- material 20 | import Material.Material 21 | 22 | import Utility.Utils 23 | import Prelude hiding (subtract) 24 | 25 | data MovingSphere = MovSphereObj {msphereCenter1 :: Vector, 26 | msphereCenter2 :: Vector, 27 | msphereRadius :: Double, 28 | msphereMat :: Material, 29 | mTime0 :: Double, 30 | mTime1 :: Double} 31 | 32 | getMSphereCenter :: MovingSphere -> Double -> Vector 33 | getMSphereCenter !(MovSphereObj {msphereCenter1 = a, 34 | msphereCenter2 = b, 35 | msphereRadius = c, 36 | msphereMat = d, 37 | mTime0 = e, 38 | mTime1 = f }) !time = 39 | let tratio = (time - e) / (f - e) 40 | centerDiff = subtract b a 41 | mc = multiplyS centerDiff tratio 42 | in add a mc 43 | 44 | 45 | getSphereUV :: Vector -> (Double, Double) 46 | getSphereUV v = 47 | let (x: y: z:_) = vec2List v 48 | theta = acos (-y) 49 | phi = (atan2 (-z) x) + m_pi 50 | in (phi / (2*m_pi), theta / m_pi) 51 | 52 | 53 | instance Eq MovingSphere where 54 | a == b = 55 | let MovSphereObj {msphereCenter1 = c, msphereCenter2 = d, 56 | msphereRadius = e, msphereMat = _} = a 57 | MovSphereObj {msphereCenter1 = g, msphereCenter2 = h, 58 | msphereRadius = i, msphereMat = _} = b 59 | in (c == g) && (d == h) && (e == i) -- && (f == j) 60 | 61 | instance Show MovingSphere where 62 | show (MovSphereObj {msphereCenter1 = a, 63 | msphereCenter2 = b, 64 | msphereRadius = c, 65 | msphereMat = _}) = 66 | let m1 = "Moving Shpere with " 67 | m2 = m1 ++ "center1 " ++ show a 68 | m3 = m2 ++ " center2 " ++ show b 69 | m4 = m3 ++ " radius " ++ show c 70 | -- m5 = m4 ++ " material " ++ show d 71 | in m4 72 | 73 | 74 | instance Hittable MovingSphere where 75 | {-# INLINE hit #-} 76 | hit !s g !(Rd {origin = ro, rtime = t0, 77 | direction = rd, wavelength = rwave}) !tmin !tmax !hrec = 78 | let sr = msphereRadius s 79 | sm = msphereMat s 80 | sc = (getMSphereCenter s t0) 81 | oc = subtract ro sc 82 | a = lengthSquared rd 83 | hb = dot oc rd 84 | c = (lengthSquared oc) - (sr * sr) 85 | discriminant = hb * hb - a * c 86 | ry = Rd {origin = ro, direction = rd, rtime = t0, 87 | wavelength = rwave} 88 | in if discriminant < 0 89 | then (hrec, False, g) 90 | else let sqd = sqrt discriminant 91 | root = (-hb - sqd) / a 92 | nroot = (-hb + sqd) / a 93 | cond1 = root < tmin || tmax < root 94 | cond2 = nroot < tmin || tmax < nroot 95 | in if cond1 96 | then if cond2 97 | then (hrec, False, g) 98 | else let hpoint = at ry nroot 99 | hnorm = divideS (subtract hpoint sc) sr 100 | (hu, hv) = getSphereUV hnorm 101 | hr = HRec {hdist = nroot, point = hpoint, 102 | pnormal = hnorm, 103 | matPtr = sm, 104 | hUV_u = hu, 105 | hUV_v = hv, 106 | isFront = False} 107 | in (setFaceNormal hr ry hnorm, True, g) 108 | else let hpoint = at ry root 109 | hnorm = divideS (subtract hpoint sc) sr 110 | (hu, hv) = getSphereUV hnorm 111 | hr = HRec {hdist = root, point = hpoint, 112 | pnormal = hnorm, matPtr = sm, 113 | hUV_u = hu, hUV_v = hv, 114 | isFront = False} 115 | in (setFaceNormal hr ry hnorm, True, g) 116 | 117 | boundingBox !s !time0 !time1 !ab = 118 | let ct0 = getMSphereCenter s time0 119 | ct1 = getMSphereCenter s time1 120 | srad = msphereRadius s 121 | vrad = fromList2Vec srad [srad, srad] 122 | ab1 = AaBbox {aabbMin = subtract ct0 vrad, aabbMax = add ct0 vrad} 123 | ab2 = AaBbox {aabbMin = subtract ct1 vrad, aabbMax = add ct1 vrad} 124 | in (ssBox ab1 ab2, True) 125 | 126 | pdf_value a g orig v = 127 | let hr = emptyRec 128 | ry = Rd {origin = orig, direction = v, 129 | rtime = 0.0, wavelength = 0} 130 | (ahit, isHit, g1) = hit a g ry 0.001 (infty) hr 131 | in if not isHit 132 | then RandResult (0.0, g1) 133 | else let cent = getMSphereCenter a 0.0 134 | corg = lengthSquared $! subtract cent orig 135 | radius = msphereRadius a 136 | radorg = (radius * radius) / corg 137 | costheta = sqrt $! 1.0 - radorg 138 | solidAngle = 2.0 * m_pi * (1.0 - costheta) 139 | in RandResult (1.0 / solidAngle, g1) 140 | 141 | hrandom a g orig = 142 | let cent = getMSphereCenter a 0.0 143 | dir = subtract cent orig 144 | distSqr = lengthSquared dir 145 | onb = fromW2Onb dir 146 | radius = msphereRadius a 147 | res = random2Sphere g (radius, distSqr) 148 | in rfmap (localVec onb) res 149 | 150 | -------------------------------------------------------------------------------- /src/Math3D/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- Basic Matrix implementation 3 | module Math3D.Matrix where 4 | 5 | import Math3D.Vector hiding(sizeError) 6 | import Math3D.CommonOps 7 | import GHC.Float 8 | import Data.List 9 | import Data.Foldable 10 | import Debug.Trace 11 | 12 | import Utility.Utils 13 | import Utility.HelperTypes 14 | 15 | data Matrix = MList {mdata :: NonEmptyList Double, 16 | mstride :: Int} 17 | 18 | instance Eq Matrix where 19 | a == b = let ma = nl2List $! mdata a 20 | mb = nl2List $! mdata b 21 | msa = mstride a 22 | msb = mstride b 23 | in (ma == mb) && (msa == msb) 24 | 25 | 26 | instance Show Matrix where 27 | show m = 28 | let msg1 = "" 30 | 31 | mzero :: Int -> Int -> Matrix 32 | mzero !rowNb !colNb = 33 | let (m:ms) = replicate (rowNb * colNb) 0.0 34 | in MList {mdata = fromList2NL m ms, 35 | mstride = colNb} 36 | 37 | matFromVector :: NonEmptyList Vector -> Matrix 38 | matFromVector vvs = 39 | -- let myStrList = lines myStr -- \n 40 | -- in [splitOn ',' myStr | myStr <- myStrList] 41 | let (v:vs) = nl2List vvs 42 | sizes = [(vsize v_) == (vsize v) | v_ <- v:vs] 43 | allSameLength = foldl1 (==) sizes 44 | in if not allSameLength 45 | then traceStack "All vectors must have same length" (mzero 1 1) 46 | else -- foldfn :: (a -> b -> a) 47 | let foldfn ac p = let a = vec2List p in ac ++ a 48 | (m:ms) = foldl foldfn [] (v:vs) 49 | in MList {mdata = fromList2NL m ms, mstride = vsize v} 50 | 51 | 52 | mrows :: Matrix -> [Vector] 53 | mrows !m = 54 | let d = nl2List $! mdata m 55 | s = mstride m 56 | rowNb = mRowNb m 57 | vlst = [takeBetween (s*i) (s*i + s-1) d | i <- [0..(rowNb - 1)]] 58 | f v = fromList2NL (head v) (tail v) 59 | in map (VList . f) vlst 60 | 61 | 62 | mcols :: Matrix -> [Vector] 63 | mcols !m = 64 | let rows = mrows m 65 | getcol i = let (v:vs) = [vget row i | row <-rows] in fromList2NL v vs 66 | in [VList $ getcol i | i <- [0..((mColNb m)-1)]] 67 | 68 | 69 | msize :: Matrix -> Int 70 | msize !m = lengthNL (mdata m) 71 | 72 | mget :: Matrix -> Int -> Int -> Double 73 | mget !mat col row = vget (mgetRow mat row) col 74 | 75 | mRowNb :: Matrix -> Int 76 | mRowNb mat = 77 | let m1 = int2Double (msize mat) 78 | m2 = int2Double (mstride mat) 79 | in double2Int $! m1 / m2 80 | 81 | mColNb :: Matrix -> Int 82 | mColNb = mstride 83 | 84 | mgetColumn :: Matrix -> Int -> Vector 85 | mgetColumn mat index = 86 | if index >= (mstride mat) 87 | then let msg1 = "given column index is larger than stride " ++ show (mstride mat) 88 | msg2 = msg1 ++ " index " ++ show index 89 | in traceStack msg2 zeroV3 90 | else (mcols mat) !! index 91 | 92 | mgetRow :: Matrix -> Int -> Vector 93 | mgetRow mat index = 94 | if index >= (mRowNb mat) 95 | then let msg1 = "given row index is larger than number of rows of matrix" 96 | msg2 = " index " ++ show index 97 | msg3 = " row number " ++ show (mRowNb mat) 98 | in traceStack (msg1 ++ msg2 ++ msg3) zeroV3 99 | else (mrows mat) !! index 100 | 101 | msetRow :: Matrix -> Int -> Vector -> Matrix 102 | msetRow mat index v = 103 | if index >= (mRowNb mat) 104 | then traceStack "given row index is larger than number of rows of matrix" (mzero 1 1) 105 | else let md = nl2List $! mdata mat 106 | colnb = mColNb mat 107 | VList vs = v 108 | loc = index * colnb 109 | rowend = loc + colnb 110 | (before, rdata) = splitAt loc md 111 | (berdata, after) = splitAt rowend md 112 | (m:ms) = before ++ (nl2List vs) ++ after 113 | in MList {mdata = fromList2NL m ms, mstride = mstride mat} 114 | 115 | 116 | 117 | sizeError :: Matrix -> Matrix -> String -> String 118 | sizeError !v !s m = 119 | let msg = "matrix sizes: " ++ (show $! msize v) ++ " and " ++ (show $! msize s) 120 | msg2 = msg ++ " are incorrect for operation " ++ m 121 | in msg2 122 | 123 | matError :: Matrix -> String -> String 124 | matError !v m = 125 | let msg = "matrix: " ++ show v ++ " " ++ m 126 | in msg 127 | 128 | matArithmeticOp :: String -> (Double -> Double -> Double) -> Matrix -> Matrix -> Matrix 129 | matArithmeticOp opname f !v !e 130 | | (msize v) /= (msize e) = traceStack (sizeError v e opname) (mzero 2 2) 131 | | (mstride v) /= (mstride e) = traceStack (sizeError v e opname) (mzero 2 2) 132 | | otherwise = 133 | let ds = nl2List $! mdata v 134 | es = nl2List $! mdata e 135 | (m:ms) = zipWith f ds es 136 | in MList {mdata = fromList2NL m ms, mstride = mstride v} 137 | 138 | matScalarOp :: String -> (Double -> Double) -> Matrix -> Matrix 139 | matScalarOp _ f !v = 140 | let (m:ms) = map f (nl2List $! mdata v) 141 | in MList {mdata = fromList2NL m ms, mstride = mstride v} 142 | 143 | instance BinaryOps Matrix where 144 | elementwiseOp = matArithmeticOp 145 | elementwiseScalarOp = matScalarOp 146 | divide !v !e = 147 | let es = nl2List $! mdata e 148 | in if 0.0 `elem` es 149 | then error $ matError e "contains zero in a division operation" 150 | else matArithmeticOp "divide" (/) v e 151 | 152 | -- get XbyY times YbyZ -> XbyZ 153 | matmul :: Matrix -> Matrix -> Matrix 154 | matmul !a !b = 155 | let aColNb = mColNb a 156 | aRowNb = mRowNb a 157 | bColNb = mColNb b 158 | bRowNb = mRowNb b 159 | in if aColNb /= bRowNb 160 | then let msg1 = "SizeError :: argument matrices have incompatible size " 161 | msg2 = msg1 ++ (show aRowNb) 162 | msg3 = msg2 ++ "x" ++ (show aColNb) 163 | msg4 = msg3 ++ " and " ++ (show bRowNb) ++ "x" ++ (show bColNb) 164 | in traceStack msg4 (mzero 1 1) 165 | else -- real multiplication work begins 166 | let bcols = mcols b 167 | arows = mrows a 168 | fn arow = [dot arow bcol | bcol <- bcols] 169 | (m:ms) = concat $ map fn arows 170 | in MList {mdata = fromList2NL m ms, mstride = bColNb} 171 | -------------------------------------------------------------------------------- /src/Spectral/SampledDistribution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- sampled spectral distribution 4 | module Spectral.SampledDistribution where 5 | 6 | import Math3D.Vector 7 | import Math3D.CommonOps 8 | 9 | import Utility.HelperTypes 10 | import Utility.Utils as Ut 11 | import Utility.BaseEnum 12 | 13 | -- third party 14 | import qualified Data.Map as DMap 15 | import GHC.Float 16 | import Data.List 17 | import Debug.Trace 18 | 19 | data SampledWavePower = SampledWP (NonEmptyList (WaveVal, PowerVal)) 20 | 21 | instance Eq SampledWavePower where 22 | (SampledWP a) == (SampledWP b) = a == b 23 | 24 | instance Show SampledWavePower where 25 | show (SampledWP a) = " NonEmptyList WaveVal 29 | wavelengths (SampledWP dmap) = let ((w:ws), _) = unzip (nl2List dmap) 30 | in fromList2NL w ws 31 | 32 | powers :: SampledWavePower -> Vector 33 | powers (SampledWP dmap) = let (_, (p:ps)) = unzip (nl2List dmap) 34 | in fromList2Vec p ps 35 | 36 | fromWavesPowers :: NonEmptyList PowerVal -> NonEmptyList WaveVal -> SampledWavePower 37 | fromWavesPowers pwrs wvs = 38 | if (lengthNL pwrs) /= (lengthNL wvs) 39 | then let errmsg = "number of powers do not match to number of waves" 40 | in traceStack errmsg (SampledWP (fromList2NL (0,0.0) [])) 41 | else let (n:ns) = zip (nl2List wvs) (nl2List pwrs) 42 | in SampledWP $! fromList2NL n ns 43 | 44 | wavesCheck :: SampledWavePower -> SampledWavePower -> (Bool, String, NonEmptyList WaveVal, NonEmptyList WaveVal) 45 | wavesCheck a b = 46 | let aw = wavelengths a 47 | bw = wavelengths b 48 | in (aw /= bw, "wavelengths differ for sampled power distributions", aw, bw) 49 | 50 | 51 | sortSampledWavePower :: SampledWavePower -> SampledWavePower 52 | sortSampledWavePower a = let SampledWP b = a 53 | (m:ms) = sortOn fst (nl2List b) 54 | in SampledWP $! fromList2NL m ms 55 | 56 | -- common operations 57 | instance BinaryOps SampledWavePower where 58 | elementwiseOp str f a b = 59 | let (areWavelengthsNotSame, str2, aw, bw) = wavesCheck a b 60 | in if areWavelengthsNotSame 61 | then traceStack (str2 ++ " :: " ++ str) (zeroLike a) 62 | else let ap = powers a 63 | bp = powers b 64 | VList npwrs = vecArithmeticOp str f ap bp 65 | in fromWavesPowers npwrs aw 66 | -- 67 | elementwiseScalarOp str f a = let ap = powers a 68 | VList npwrs = vecScalarOp f ap 69 | in fromWavesPowers npwrs (wavelengths a) 70 | 71 | -- division 72 | divide a b = 73 | let (areWavelengthsNotSame, str, aw, bw) = wavesCheck a b 74 | in if areWavelengthsNotSame 75 | then traceStack (str) (zeroLike a) 76 | else let ap = powers a 77 | bp = powers b 78 | VList npwrs = divide ap bp 79 | in fromWavesPowers npwrs aw 80 | 81 | 82 | minmaxPower :: ([PowerVal] -> PowerVal) -> SampledWavePower -> PowerVal 83 | minmaxWavelength :: ([WaveVal] -> WaveVal) -> SampledWavePower -> WaveVal 84 | 85 | minmaxPower f dmap = let ps = vec2List (powers dmap) in f ps 86 | 87 | minmaxWavelength f dmap = let ps = nl2List (wavelengths dmap) in f ps 88 | 89 | maxPower :: SampledWavePower -> PowerVal 90 | maxPower a = minmaxPower maximum a 91 | minPower :: SampledWavePower -> PowerVal 92 | minPower a = minmaxPower minimum a 93 | 94 | maxWavelength :: SampledWavePower -> WaveVal 95 | maxWavelength a = minmaxWavelength maximum a 96 | 97 | minWavelength :: SampledWavePower -> WaveVal 98 | minWavelength a = minmaxWavelength minimum a 99 | 100 | zeroLike :: SampledWavePower -> SampledWavePower 101 | zeroLike a = 102 | let wls = wavelengths a 103 | pwrs = powers a 104 | VList b = zeroV (vsize pwrs) 105 | in fromWavesPowers b wls 106 | 107 | 108 | -- interpolate a spectral power distribution 109 | interpolate :: SampledWavePower -> (PowerVal, PowerVal) -> SampledWavePower 110 | interpolate b (mn, mx) = 111 | let minmaxer f = f [mn, mx] 112 | amin = minmaxer minimum 113 | amax = minmaxer maximum 114 | pmin = minPower b 115 | pmax = maxPower b 116 | ps = powers b 117 | interpolator p = Ut.interp (pmin, pmax) (amin, amax) p 118 | interpolatedPowers = map interpolator (vec2List ps) 119 | skeys = nl2List $! wavelengths b 120 | (n:ns) = zip skeys interpolatedPowers 121 | in SampledWP $! fromList2NL n ns 122 | 123 | -- clamp a spectral power distribution 124 | 125 | clamp :: SampledWavePower -> (PowerVal, PowerVal) -> SampledWavePower 126 | clamp a (mn, mx) = 127 | let ps = powers a 128 | clamper p = Ut.clamp p mn mx 129 | clampedPowers = map clamper (vec2List ps) 130 | skeys = nl2List $! wavelengths a 131 | (n:ns) = zip skeys clampedPowers 132 | in SampledWP (fromList2NL n ns) 133 | 134 | normalize :: SampledWavePower -> SampledWavePower 135 | normalize a = interpolate a (0.0, 1.0) 136 | 137 | evaluateWave :: WaveVal -> SampledWavePower -> PowerVal 138 | 139 | evaluateWave wave b = 140 | -- in range 141 | let (SampledWP a) = b 142 | inRange = (wave >= (minWavelength b)) && (wave <= (maxWavelength b)) 143 | waves = wavelengths b 144 | isMember = elemNL wave waves 145 | getPower w = let pred (wp, pp) = wp == w 146 | in case findNL pred a of 147 | Just (_, p) -> p 148 | Nothing -> -1.0 149 | wavePred w = let pred (wp, pp) = wp <= w 150 | in partitionNL pred a 151 | in if isMember -- wavelength is a member, we can access to its power 152 | then getPower wave 153 | else if inRange -- wavelength is in range, we can interpolate power values 154 | then let (smallerLst, largerLst) = wavePred wave 155 | (smallMaxWave, smallPower) = last $! sortOn fst smallerLst 156 | (largeMinWave, largePower) = head $! sortOn fst largerLst 157 | in (smallPower + largePower) / 2.0 158 | else -- it is not in range nor a member this can not be evaluated 159 | let msg = "given wavelength " ++ (show wave) ++ " is outside" 160 | msg2 = " of sampled spectrum whose limits are " 161 | msg3 = show (minWavelength b) 162 | msg4 = show (maxWavelength b) 163 | in traceStack (msg ++ msg2 ++ msg3 ++ " and " ++ msg4) 0.0 164 | -------------------------------------------------------------------------------- /src/Hittable/Rotatable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | -- rotatable 5 | module Hittable.Rotatable where 6 | 7 | import Hittable.Hittable 8 | import Hittable.Aabb 9 | import Hittable.HitRecord 10 | 11 | -- math3d 12 | import Math3D.Matrix 13 | import Math3D.Vector 14 | import Math3D.CommonOps 15 | import Math3D.Ray 16 | 17 | -- utility 18 | import Utility.Utils 19 | import Utility.HelperTypes 20 | 21 | -- 22 | import Prelude hiding(subtract) 23 | import Data.Foldable 24 | import Data.List 25 | import GHC.Float 26 | 27 | 28 | data RotationAxis = RX 29 | | RY 30 | | RZ 31 | deriving(Eq) 32 | 33 | instance Show RotationAxis where 34 | show r = case r of 35 | RX -> "X" 36 | RY -> "Y" 37 | RZ -> "Z" 38 | 39 | toMatrix :: RotationAxis -> Double -> Matrix 40 | toMatrix r theta = case r of 41 | RX -> let matv1 = fromList2Vec 1.0 [0.0, 0.0] 42 | matv2 = fromList2Vec 0.0 [cos theta, -(sin theta)] 43 | matv3 = fromList2Vec 0.0 [sin theta, cos theta] 44 | in matFromVector (fromList2NL matv1 [ matv2, matv3]) 45 | RY -> let matv1 = fromList2Vec (cos theta) [0.0, sin theta] 46 | matv2 = fromList2Vec 0.0 [1.0, 0.0] 47 | matv3 = fromList2Vec (-(sin theta)) [0.0, cos theta] 48 | in matFromVector (fromList2NL matv1 [matv2, matv3]) 49 | RZ -> let matv1 = fromList2Vec (cos theta) [-(sin theta), 0.0] 50 | matv2 = fromList2Vec (sin theta) [cos theta, 0.0] 51 | matv3 = fromList2Vec 0.0 [0.0, 1.0] 52 | in matFromVector (fromList2NL matv1 [matv2, matv3]) 53 | 54 | rotateByMatrix :: Vector -> Matrix -> Vector 55 | rotateByMatrix (VList ps) rotmat = 56 | let pmat = MList {mdata = ps, mstride = 1} 57 | -- obtain rotated point vector 58 | in VList $ mdata (matmul rotmat pmat) 59 | 60 | 61 | data Rotatable where 62 | Rotate :: (Show a, Hittable a, Eq a) => a -> Double -> RotationAxis -> Bool -> Aabb -> String -> Rotatable 63 | 64 | instance Show Rotatable where 65 | show (Rotate a angle axis _ _ _) = 66 | let msg1 = "" 68 | in msg1 ++ msg2 69 | 70 | instance Eq Rotatable where 71 | a == b = 72 | case a of 73 | (Rotate _ angle axis _ _ an) -> 74 | case b of 75 | (Rotate _ bngle bxis _ _ bn) -> 76 | (an == bn) && (angle == bngle) && (axis == bxis) 77 | 78 | innerRotatable :: Int -> Int -> Int -> Aabb -> Matrix -> Vector -> Vector -> (Vector, Vector) 79 | innerRotatable i j k bbox rotmat minv maxv = 80 | let mnmxMult key index = let bmax = (vget (aabbMax bbox) index) * key 81 | bmin = (vget (aabbMin bbox) index) * (1 - key) 82 | in bmax + bmin 83 | xval = mnmxMult (int2Double i) 0 84 | yval = mnmxMult (int2Double j) 1 85 | zval = mnmxMult (int2Double k) 2 86 | -- make matrix for rotation 87 | pmat = MList {mdata = fromList2NL xval [yval, zval], mstride = 1} 88 | -- obtain rotated point vector 89 | rotated = mdata (matmul rotmat pmat) 90 | VList mnvs = minv 91 | VList mxvs = maxv 92 | f compfn lst = [compfn [mv, rv] | (mv, rv) <- nl2List $! zipNL rotated lst] 93 | (m:ms) = f minimum mnvs 94 | (n:ns) = f maximum mxvs 95 | in (fromList2Vec m ms, fromList2Vec n ns) 96 | 97 | mkRotatable :: (Show a, Hittable a, Eq a) => a -> Double -> RotationAxis -> String -> Rotatable 98 | mkRotatable ptr angle axis = 99 | let (ab, hasAb) = boundingBox ptr 0 1 zeroAabb3 100 | rotmat = toMatrix axis angle 101 | -- (a -> b -> a) -> [b] -> a 102 | kfoldfn i j = [(i,j,k) | k <- [0,1,2]] 103 | jfoldfn i = concat [kfoldfn i j | j <- [0,1,2]] 104 | inds = concat [jfoldfn i | i <- [0,1,2]] 105 | rotFold acc indices = let (i, j, k) = indices 106 | (minv, maxv) = acc 107 | in innerRotatable i j k ab rotmat minv maxv 108 | minStart = inftyV3 109 | maxStart = negInftyV3 110 | (minv, maxv) = foldl' rotFold (minStart, maxStart) inds 111 | box = AaBbox {aabbMin = minv, aabbMax = maxv} 112 | in Rotate ptr angle axis hasAb box 113 | 114 | 115 | instance Hittable Rotatable where 116 | hit (Rotate a angle axis _ _ _) g ry tmin tmax hrec = 117 | -- 118 | let theta = degrees_to_radians angle 119 | rotmat = toMatrix axis theta 120 | invrot = toMatrix axis (-theta) 121 | ro = origin ry 122 | rd = direction ry 123 | rro = rotateByMatrix ro rotmat -- rotated origin 124 | rrd = rotateByMatrix rd rotmat -- rotated direction 125 | nry = Rd { origin = rro, direction = rrd, 126 | rtime = rtime ry, wavelength = wavelength ry } 127 | (srec, isHit, g1) = hit a g nry tmin tmax hrec 128 | in if not isHit 129 | then (srec, isHit, g1) 130 | else let invp = rotateByMatrix (point srec) invrot 131 | invn = rotateByMatrix (pnormal srec) invrot 132 | HRec { 133 | hdist = h1, point = h2, pnormal = h3, matPtr = h4, 134 | hUV_u = h5, hUV_v = h6, isFront = h7 135 | } = srec 136 | nsrec = HRec {hdist = h1, point = invp, pnormal = invn, 137 | matPtr = h4, hUV_u = h5, hUV_v = h6, 138 | isFront = h7} 139 | in (setFaceNormal nsrec nry invn, True, g1) 140 | 141 | -- there is a problem here the bounding box does not care about the time 142 | -- TODO 143 | boundingBox (Rotate a angle axis hasBox bbox _) tmn tmx ab = (bbox, hasBox) 144 | 145 | pdf_value a g orig v = 146 | case a of 147 | (Rotate b angle axis _ _ _) -> 148 | let theta = degrees_to_radians angle 149 | rotmat = toMatrix axis theta 150 | invrot = toMatrix axis (-theta) 151 | rro = rotateByMatrix orig rotmat -- rotated origin 152 | rrd = rotateByMatrix v rotmat -- rotated direction 153 | in pdf_value b g rro rrd 154 | 155 | hrandom a g orig = 156 | case a of 157 | (Rotate b angle axis _ _ _) -> 158 | let theta = degrees_to_radians angle 159 | rotmat = toMatrix axis theta 160 | invrot = toMatrix axis (-theta) 161 | rro = rotateByMatrix orig rotmat -- rotated origin 162 | in hrandom b g rro 163 | -------------------------------------------------------------------------------- /src/Hittable/Bvh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- bounding volume hierarchy 4 | module Hittable.Bvh where 5 | 6 | import Hittable.Hittable 7 | import Hittable.HittableList 8 | import Hittable.HittableObj 9 | import Hittable.HitRecord 10 | import Hittable.Aabb 11 | 12 | import Math3D.Vector 13 | 14 | import Utility.HelperTypes 15 | 16 | import Random 17 | import GHC.Float 18 | import System.Random 19 | import Data.Ord 20 | import Data.List 21 | 22 | data Bvh where 23 | BNode :: Bvh -> Bvh -> Aabb -> Bvh 24 | BLeaf :: (Show a, Eq a, Hittable a) => a -> Aabb -> Bvh 25 | 26 | instance Eq Bvh where 27 | a == b = 28 | case a of 29 | (BNode _ _ ab) -> 30 | case b of 31 | (BNode _ _ ab2) -> ab == ab2 32 | _ -> False 33 | (BLeaf _ ab) -> 34 | case b of 35 | (BLeaf _ ab2) -> ab == ab2 36 | _ -> False 37 | 38 | instance Show Bvh where 39 | show a = case a of 40 | (BNode a1 a2 _) -> 41 | let msg = "" 43 | in msg ++ msg2 44 | (BLeaf a1 _) -> "" 45 | 46 | 47 | instance Hittable Bvh where 48 | {-# INLINE hit #-} 49 | -- hit :: bvh -> randgen -> Ray -> Double -> Double -> HitRecord -> (HitRecord, Bool) 50 | hit !bvh !g !ray !tmin !tmax !hrec = 51 | case bvh of 52 | (BNode a b box) -> 53 | let boxHit = aabbHit box ray tmin tmax 54 | in if not boxHit 55 | then (hrec, False, g) 56 | else let (leftHrec, isLeftHit, g1) = hit a g ray tmin tmax hrec 57 | t_max = if isLeftHit 58 | then hdist leftHrec 59 | else tmax 60 | (rightHrec, isRightHit, g2) = hit b g1 ray tmin t_max hrec 61 | in if isRightHit 62 | then (rightHrec, True, g2) 63 | else if isLeftHit 64 | then (leftHrec, True, g1) 65 | else (hrec, False, g) 66 | (BLeaf a box) -> 67 | if not $! aabbHit box ray tmin tmax 68 | then (hrec, False, g) 69 | else hit a g ray tmin tmax hrec 70 | 71 | 72 | -- boundingBox :: bvh -> Double -> Double -> Aabb -> (Aabb, Bool) 73 | boundingBox mbvh _ _ _ = 74 | case mbvh of 75 | (BNode _ _ a) -> (a, True) 76 | (BLeaf _ a) -> (a, True) 77 | 78 | -- pdf value 79 | pdf_value _ g _ _ = RandResult (0.0, g) 80 | hrandom _ g _ = randomVec (0.0, 1.0) g 81 | 82 | 83 | mkBvh :: (Show a, Eq a, Hittable a, RandomGen g) => [a] -> g -> Int -> Int -> Double -> Double -> Bvh 84 | 85 | mkBvh !objects !gen !start !end !time0 !time1 = 86 | let resAxis = randomDouble gen (0.0, 2.0) 87 | RandResult (axis, g1) = rfmap double2Int resAxis 88 | compareFn | axis == 0 = box_x_compare 89 | | axis == 1 = box_y_compare 90 | | otherwise = box_z_compare 91 | object_span = end - start 92 | (leftObj, rightObj) 93 | -- there is a single object 94 | | object_span == 1 = let fobj = objects !! start 95 | (fBox, _) = boundingBox fobj 0.0 1.0 zeroAabb3 96 | in (BLeaf fobj fBox, BLeaf fobj fBox) 97 | -- there are two objects 98 | | object_span == 2 = let fobj = objects !! start 99 | sobj = objects !! (start + 1) 100 | (fBox, _) = boundingBox fobj 0.0 1.0 zeroAabb3 101 | (sBox, _) = boundingBox sobj 0.0 1.0 zeroAabb3 102 | in case compareFn fobj sobj of 103 | LT -> (BLeaf fobj fBox, 104 | BLeaf sobj sBox) 105 | GT -> (BLeaf sobj sBox, 106 | BLeaf fobj fBox) 107 | EQ -> (BLeaf sobj sBox, 108 | BLeaf fobj fBox) 109 | -- there are multiple objects 110 | | otherwise = let -- let's sort the given range 111 | indicesList = [0..(length objects)] 112 | objEnum = zip indicesList objects 113 | lstComp (fInd, fObj) (sInd, sObj) 114 | | fInd < start = EQ 115 | | sInd > end = EQ 116 | | otherwise = compareFn fObj sObj 117 | 118 | -- sortedEnumObjs :: [((Int, a), (Int, a))] 119 | sortedEnumObjs = sortBy lstComp objEnum; 120 | (indices, sortedObjs) = unzip sortedEnumObjs; 121 | 122 | spdouble = int2Double object_span; 123 | stdouble = int2Double start; 124 | middle = stdouble + (spdouble / 2); 125 | mid = double2Int middle; 126 | left = mkBvh sortedObjs g1 start mid time0 time1; 127 | right = mkBvh sortedObjs g1 mid end time0 time1; 128 | (lbox, _) = boundingBox left time0 time1 zeroAabb3; 129 | (rbox, _) = boundingBox right time0 time1 zeroAabb3; 130 | in (left, right) 131 | -- we have the left and right branch, now aabb 132 | (leftBox, isLBox) = boundingBox leftObj time0 time1 zeroAabb3 133 | (rightBox, isRBox) = boundingBox rightObj time0 time1 zeroAabb3 134 | in if (not isLBox) || (not isRBox) 135 | then error "bvh node does not have a bounding box" 136 | else let bvhBox = ssBox leftBox rightBox 137 | in BNode leftObj rightObj bvhBox 138 | where boxCompare firstObject secondObject compareAxis = 139 | let (fBox, isfBox) = boundingBox firstObject 0.0 1.0 zeroAabb3 140 | (sBox, issBox) = boundingBox secondObject 0.0 1.0 zeroAabb3 141 | in if (not isfBox) || (not issBox) 142 | then error "bvh node does not have a bounding box in compare" 143 | else let fVal = vget (aabbMin fBox) compareAxis 144 | sVal = vget (aabbMin sBox) compareAxis 145 | in if fVal < sVal 146 | then LT 147 | else if sVal < fVal 148 | then GT 149 | else EQ 150 | 151 | box_x_compare f s = boxCompare f s 0 152 | box_y_compare f s = boxCompare f s 1 153 | box_z_compare f s = boxCompare f s 2 154 | 155 | mkBvhFromHittableList :: RandomGen g => HittableList -> g -> Double -> Double -> Bvh 156 | 157 | mkBvhFromHittableList hobjs g time0 time1 = 158 | let hs = nl2List $ objects hobjs 159 | in mkBvh hs g 0 (length hs) time0 time1 160 | -------------------------------------------------------------------------------- /src/Scene/RandomOneWeekendFinal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- one weekend final scene 3 | module Scene.RandomOneWeekendFinal( 4 | randomOneWeekendFinalScene, 5 | randomOneWeekendFinalSceneMove, 6 | randomOneWeekendFinalSceneStatic 7 | ) where 8 | 9 | -- 10 | import System.Random 11 | import GHC.Float 12 | import Prelude hiding(subtract) 13 | 14 | -- scene defaults 15 | import Scene.Scene 16 | 17 | import Color.Pixel 18 | -- 19 | import Hittable.HittableList 20 | import Hittable.HittableObj 21 | import Hittable.Sphere 22 | import Hittable.MovingSphere 23 | 24 | -- texture 25 | import Texture.SolidColor 26 | import Texture.TextureObj 27 | 28 | -- material 29 | import Material.Material 30 | 31 | -- random 32 | import Random 33 | 34 | -- math3D 35 | import Math3D.Vector 36 | import Math3D.CommonOps 37 | 38 | -- utility 39 | import Utility.HelperTypes 40 | 41 | 42 | mkRndMat :: RandomGen g => g -> Int -> Int -> Bool -> (Maybe HittableObj, g) 43 | mkRndMat gen !a !b !isMoving = 44 | let fnlist = fromList2NL randval [randval, randval] 45 | RandResult (nlst, g3) = randFoldlFixedRange2 gen fnlist 46 | (chooseMat:cxrand:czrand:_) = nl2List nlst 47 | center = fromList2Vec ((int2Double a) + (0.9 * cxrand)) [ 48 | 0.2, 49 | (int2Double b) + (0.9 * czrand)] 50 | diff = subtract center (fromList2Vec 4.0 [0.2, 0.0]) 51 | cdiff = magnitude diff 52 | in if cdiff > 0.9 53 | then if (chooseMat > 0.3) && (chooseMat < 0.8) 54 | then let fnlst2 = fromList2NL randV [randV] 55 | RandResult (nlst2, g5) = randFoldlFixedRange2 g3 fnlst2 56 | (rv1:rv2:_) = nl2List nlst2 57 | diffAlbedo = multiply rv1 rv2 58 | r = vget diffAlbedo 0 59 | g = vget diffAlbedo 1 60 | b = vget diffAlbedo 2 61 | st1 = TextureCons $! SolidD r g b 62 | laMat = LambMat $! LambT st1 63 | in if isMoving 64 | then let RandResult (rv3, g6) = randomDouble g5 (0.0, 0.5) 65 | in (Just $! HittableCons MovSphereObj { 66 | msphereCenter1 = center, 67 | msphereCenter2 = add center (fromList2Vec 0.0 [rv3, 0.0]), 68 | msphereRadius = 0.2, 69 | msphereMat = laMat, 70 | mTime0 = 0.0, 71 | mTime1 = 1.0 72 | }, g6) 73 | else (Just $! HittableCons SphereObj {sphereCenter = center, 74 | sphereRadius = 0.2, 75 | sphereMat = laMat}, g5) 76 | else if chooseMat >= 0.8 && chooseMat < 0.9 77 | then let RandResult (rv1, g4) = randomVec (0.5, 1.0) g3 78 | RandResult (fz, g5) = randomDouble g4 (0.0, 0.5) 79 | r = vget rv1 0 80 | g = vget rv1 1 81 | b = vget rv1 2 82 | st1 = TextureCons $! SolidD r g b 83 | metMat = MetalMat $! MetT st1 fz 84 | in (Just $! HittableCons SphereObj { 85 | sphereCenter = center, 86 | sphereRadius = 0.2, 87 | sphereMat = metMat 88 | }, g5) 89 | else let dieMt = DielMat $! DielRefIndices [1.5] 90 | in (Just $! HittableCons SphereObj { 91 | sphereCenter = center, 92 | sphereRadius = 0.2, 93 | sphereMat = dieMt 94 | }, g3) 95 | else (Nothing, gen) 96 | 97 | mkRndMats :: RandomGen g => g -> Bool -> [(Int, Int)] -> [HittableObj] 98 | mkRndMats _ _ [] = [] 99 | mkRndMats gen !isMov !((a, b):es) = case mkRndMat gen a b isMov of 100 | (Just c, g) -> c : mkRndMats g isMov es 101 | (Nothing, g) -> mkRndMats g isMov es 102 | 103 | world :: RandomGen g => g -> Bool -> (HittableList, HittableList) 104 | world gen !isM = let as = [0..7] 105 | bs = [0..7] 106 | coords = [(a - 3, b - 3) | a <- as, b <- bs] 107 | objs = mkRndMats gen isM coords 108 | groundTexture = TextureCons $! SolidD 0.5 0.5 0.5 109 | groundMat = LambMat $! LambT groundTexture 110 | ground = HittableCons SphereObj { 111 | sphereCenter = fromList2Vec 0.0 [-1000.0, 0.0], 112 | sphereRadius = 1000.0, 113 | sphereMat = groundMat} 114 | dielM1 = DielMat $! DielRefIndices [1.5] 115 | lambM2Texture = TextureCons $! SolidD 0.4 0.2 0.1 116 | lambM2 = LambMat $! LambT lambM2Texture 117 | metalM3Texture = TextureCons $! SolidD 0.7 0.6 0.5 118 | metalM3 = MetalMat $! MetT metalM3Texture 0.0 119 | dielObj = HittableCons $! SphereObj { 120 | sphereCenter =fromList2Vec 0.0 [ 1.0, 0.0], 121 | sphereRadius = 1.0, 122 | sphereMat = dielM1 123 | } 124 | lambObj = HittableCons $! SphereObj { 125 | sphereCenter = fromList2Vec (-4.0) [1.0, 0.0], 126 | sphereRadius = 1.0, 127 | sphereMat = lambM2 128 | } 129 | metObj = HittableCons $! SphereObj { 130 | sphereCenter = fromList2Vec 4.0 [ 1.0, 0.0], 131 | sphereRadius = 1.0, 132 | sphereMat = metalM3 133 | } 134 | in if null objs 135 | then error $ unwords (map show objs) 136 | else (HList { 137 | objects = NList ground (objs ++ [dielObj, lambObj, metObj]) 138 | }, HList {objects = NList (head objs) (tail objs)}) 139 | 140 | 141 | worldStat :: RandomGen g => g -> (HittableList, HittableList) 142 | worldStat g = world g False 143 | 144 | worldMoving :: RandomGen g => g -> (HittableList, HittableList) 145 | worldMoving g = world g True 146 | 147 | -- book scenes 148 | 149 | 150 | randomOneWeekendFinalScene :: RandomGen g => g -> Bool -> Scene 151 | randomOneWeekendFinalScene g b = 152 | let (hl, sobjs) = world g b 153 | in SceneVals { 154 | img_width = imageWidth, 155 | aspect_ratio = aspectRatio, 156 | img_height = imageHeight, 157 | nb_samples = nbSamples, 158 | bounce_depth = bounceDepth, 159 | cam_look_from = camLookFrom, 160 | cam_look_to = camLookTo, 161 | cam_vfov = camVFov, 162 | cam_vup = camVUp, 163 | cam_focus_distance = camFocDistance, 164 | cam_aperture = 0.1, 165 | scene_obj = hl, 166 | sample_obj = sobjs, 167 | back_ground = PixSpecTrichroma (0.7,0.8,1.0) 168 | } 169 | 170 | randomOneWeekendFinalSceneStatic ::RandomGen g => g -> Scene 171 | randomOneWeekendFinalSceneStatic g = randomOneWeekendFinalScene g False 172 | 173 | randomOneWeekendFinalSceneMove ::RandomGen g => g -> Scene 174 | randomOneWeekendFinalSceneMove g = randomOneWeekendFinalScene g True 175 | -------------------------------------------------------------------------------- /src/Scene/NextWeekFinal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- next week final scene 3 | module Scene.NextWeekFinal(nextWeekFinal) where 4 | 5 | -- scene default values 6 | import Scene.Scene 7 | 8 | import Color.Pixel 9 | -- 10 | import System.Random 11 | import Random 12 | import GHC.Float 13 | import Data.Bitmap.Base 14 | import Data.Bitmap.Simple 15 | 16 | -- math 17 | import Math3D.Vector 18 | import Math3D.CommonOps 19 | import Math3D.Ray 20 | 21 | -- texture 22 | import Texture.SolidColor 23 | import Texture.TextureObj 24 | import Texture.Image 25 | import Texture.Noise 26 | 27 | -- hittable 28 | import Hittable.HittableList 29 | import Hittable.HittableObj 30 | import Hittable.Hittable 31 | import Hittable.AaRect 32 | import Hittable.Rotatable 33 | import Hittable.Translatable 34 | import Hittable.MovingSphere 35 | import Hittable.Sphere 36 | import Hittable.Bvh 37 | import Hittable.ConstantMedium 38 | 39 | -- instance 40 | import Instance.Box 41 | 42 | -- 43 | import Camera 44 | import Material.Material 45 | 46 | -- 47 | import Utility.HelperTypes 48 | 49 | mkBoxes :: RandomGen g => g -> (g, [HittableObj]) 50 | mkBoxes g = 51 | let gTexture = TextureCons $! SolidD 0.48 0.83 0.53 52 | gmat = LambMat $! LambT gTexture 53 | bcoords = zip (map int2Double [0..20]) (map int2Double [0..20]) 54 | mkbox acc (i, j) = let w = 100.0 55 | x0 = -1000.0 + (i * w) 56 | z0 = -1000.0 + (j * w) 57 | y0 = 0.0 58 | x1 = x0 + w 59 | (g1, lst) = acc 60 | RandResult (y1, g2) = randomDouble g1 (1.0, 101.0) 61 | z1 = z0 + w 62 | mnp = fromList2Vec x0 [y0, z0] 63 | mxp = fromList2Vec x1 [y1, z1] 64 | in (g2, lst ++ [HittableCons $ mkBox mnp mxp gmat]) 65 | (g2, boxes) = foldl mkbox (g, []) bcoords 66 | in (g2, boxes) 67 | 68 | mkMovSphere :: HittableObj 69 | mkMovSphere = let c1 = fromList2Vec 400.0 [ 400.0, 200.0] 70 | c2 = add c1 (fromList2Vec 30.0 [ 0.0, 0.0]) 71 | ltex = TextureCons $! SolidD 0.78 0.3 0.1 72 | lmat = LambMat $! LambT ltex 73 | in HittableCons $! MovSphereObj {msphereCenter1 = c1, 74 | msphereCenter2 = c2, 75 | msphereRadius = 50.0, 76 | mTime0 = 0.0, 77 | mTime1 = 1.0, 78 | msphereMat = lmat} 79 | 80 | earthImg :: Bitmap Word8 -> HittableObj 81 | earthImg bmp = 82 | let ptex = TextureCons $! bitmapToImageT bmp 83 | -- ptex = SolidTexture $ SolidV ( fromList2Vec [0.2, 0.3, 0.1] ) 84 | lmb = LambMat $! LambT ptex 85 | in HittableCons $! SphereObj {sphereCenter = fromList2Vec 400.0 [200.0, 400.0], 86 | sphereRadius = 100, 87 | sphereMat = lmb} 88 | 89 | noiseSphere :: RandomGen g => g -> (g, HittableObj) 90 | noiseSphere g1 = 91 | let (g2, noiseT) = mkPerlinNoiseWithSeed g1 0.1 92 | ptex = TextureCons noiseT 93 | lmb = LambMat $! LambT ptex 94 | in (g2, HittableCons $! SphereObj { 95 | sphereCenter = fromList2Vec 220.0 [280.0, 300.0], 96 | sphereRadius = 80.0, 97 | sphereMat = lmb 98 | }) 99 | 100 | mkTransformedBoxes :: RandomGen g => g -> (g, HittableObj) 101 | mkTransformedBoxes g = 102 | -- 103 | let whiteTexture = TextureCons $! SolidD 0.75 0.75 0.75 104 | whmat = LambMat $! LambT whiteTexture 105 | foldlfn acc _ = let (g1, lst) = acc 106 | RandResult (rvec, g2) = randomVec (0.0, 165.0) g1 107 | sp = HittableCons $! SphereObj { 108 | sphereCenter = rvec, 109 | sphereRadius = 10, 110 | sphereMat = whmat 111 | } 112 | in (g2, lst ++ [sp]) 113 | (g1, boxes) = foldl foldlfn (g, []) [0..999] 114 | bvhboxes = mkBvh boxes g1 0 (length boxes) 0.0 1.0 115 | rotatedBoxes = mkRotatable bvhboxes 15.0 RY 116 | transOff = fromList2Vec (-100.0) [270.0, 395.0] 117 | transBoxes = Translate bvhboxes transOff (show bvhboxes) 118 | in (g1, HittableCons transBoxes) 119 | 120 | 121 | nextWeekFinal :: RandomGen g => g -> Bitmap Word8 -> Scene 122 | nextWeekFinal gen img = 123 | let (g1, boxes) = mkBoxes gen 124 | mbvh = mkBvh boxes g1 0 (length boxes) 0.0 1.0 125 | highWhiteTexture = TextureCons $! SolidD 15.0 15.0 15.0 126 | lightMat = LightMat $! DLightEmitTextureCons highWhiteTexture 127 | light = HittableCons $! mkXzRect 123.0 423.0 147.0 412.0 554.0 lightMat 128 | -- 129 | metTexture = TextureCons $! SolidD 0.8 0.8 0.9 130 | msphere = mkMovSphere 131 | dieSp1 = HittableCons $! SphereObj { 132 | sphereCenter = fromList2Vec 260.0 [150.0, 45.0], 133 | sphereRadius = 50.0, 134 | sphereMat = DielMat $! DielRefIndices [1.5] 135 | } 136 | dieSp2 = HittableCons $! SphereObj { 137 | sphereCenter = fromList2Vec 0.0 [150.0, 145.0], 138 | sphereRadius = 50.0, 139 | sphereMat = MetalMat $! MetT metTexture 1.0 140 | } 141 | boundary1 = HittableCons $! SphereObj { 142 | sphereCenter = fromList2Vec 360.0 [150.0, 145.0], 143 | sphereRadius = 70.0, 144 | sphereMat = DielMat $! DielRefIndices [1.5] 145 | } 146 | cmed1Texture = TextureCons $! SolidD 0.2 0.4 0.9 147 | cmed1 = HittableCons $! mkConstantMedium boundary1 0.2 cmed1Texture 148 | 149 | boundary2 = HittableCons $! SphereObj { 150 | sphereCenter = zeroV3, 151 | sphereRadius = 5000.0, 152 | sphereMat = DielMat $! DielRefIndices [1.5] 153 | } 154 | 155 | cmed2Texture = TextureCons $! SolidD 1.0 1.0 1.0 156 | cmed2 = HittableCons $! mkConstantMedium boundary2 0.00001 cmed2Texture 157 | eimg = earthImg img 158 | (g2, noiseS) = noiseSphere g1 159 | (g3, tboxes) = mkTransformedBoxes g2 160 | objlst = [HittableCons mbvh, 161 | light, msphere, dieSp1, dieSp2, boundary1, 162 | cmed1, cmed2, eimg, noiseS, tboxes 163 | ] 164 | hs = HList {objects = NList ( 165 | HittableCons $ mkBvh objlst g3 0 (length objlst) 0.0 1.0 166 | ) []} 167 | -- in error $ "\nN: " ++ show b2 ++ "\nR: " ++ show b2rot ++ "\nT: " ++ show b2trans 168 | in SceneVals { 169 | img_width = imageWidth, 170 | -- img_width = 800, 171 | aspect_ratio = aspectRatio, 172 | -- aspect_ratio = 800.0 / 600.0, 173 | img_height = imageHeight, 174 | -- img_height = 600, 175 | nb_samples = 100, 176 | bounce_depth = 20, 177 | cam_look_from = fromList2Vec 478.0 [ 278.0, -600.0], 178 | cam_look_to = fromList2Vec 278.0 [ 278.0, 0.0], 179 | cam_vfov = 40.0, 180 | cam_vup = camVUp, 181 | cam_focus_distance = camFocDistance, 182 | cam_aperture = 0.0, 183 | scene_obj = hs, 184 | sample_obj = HList {objects = NList light [dieSp1,boundary1,tboxes]}, 185 | back_ground = PixSpecTrichroma (0.0,0.0,0.0) 186 | } 187 | -------------------------------------------------------------------------------- /src/Spectral/SampledSpectrum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- sampled spectrum 3 | module Spectral.SampledSpectrum where 4 | 5 | import Spectral.SampledDistribution 6 | import Spectral.PbrSpectrum 7 | import Spectral.PbrtSpecdata 8 | import Spectral.SpectrumUtils 9 | 10 | -- transform spectrum to a color 11 | import Color.Colorable 12 | 13 | -- vector 14 | import Math3D.Vector 15 | import Math3D.CommonOps 16 | 17 | -- utilities 18 | import Utility.Utils hiding (clamp) 19 | import Utility.HelperTypes 20 | 21 | -- third party 22 | import GHC.Float hiding (clamp) 23 | import Debug.Trace 24 | 25 | data SpectrumType = REFLECTANCE 26 | | ILLUMINANT 27 | deriving (Show, Eq) 28 | 29 | data SampledSpectrum = SSpec { 30 | -- Spectrum Type 31 | spectrumType :: SpectrumType, 32 | -- sampled data 33 | sampled :: SampledWavePower 34 | } deriving (Eq, Show) 35 | 36 | zeroLikeSpectrum :: SampledSpectrum -> SampledSpectrum 37 | zeroLikeSpectrum a = SSpec {spectrumType = spectrumType a, 38 | sampled = zeroLike $! sampled a} 39 | 40 | zeroSampledSpectrum :: SampledSpectrum 41 | zeroSampledSpectrum = SSpec { 42 | spectrumType = REFLECTANCE, 43 | sampled = SampledWP (fromList2NL (0.0, -1.0) []) 44 | } 45 | 46 | -- create spd from rgb values 47 | fromRGB :: Double -> Double -> Double -> SpectrumType -> SampledWavePower 48 | fromRGB r g b t = 49 | let zspd = zeroLike spdRGBRefl2SpectWhite 50 | -- 51 | whiteR = spdRGBRefl2SpectWhite 52 | cyanR = spdRGBRefl2SpectCyan 53 | blueR = spdRGBRefl2SpectBlue 54 | magentaR = spdRGBRefl2SpectMagenta 55 | greenR = spdRGBRefl2SpectGreen 56 | yellowR = spdRGBRefl2SpectYellow 57 | redR = spdRGBRefl2SpectRed 58 | 59 | whiteI = spdRGBIllum2SpectWhite 60 | cyanI = spdRGBIllum2SpectCyan 61 | blueI = spdRGBIllum2SpectBlue 62 | magentaI = spdRGBIllum2SpectMagenta 63 | greenI = spdRGBIllum2SpectGreen 64 | yellowI = spdRGBIllum2SpectYellow 65 | redI = spdRGBIllum2SpectRed 66 | 67 | whiter s = multiplyS whiteR s 68 | whitei s = multiplyS whiteI s 69 | cond1 = r <= g && r <= b 70 | cond2 = g <= r && g <= b 71 | 72 | condfn f s b1 b2 spec1 spec2 spec3 = 73 | let zspd2 = add zspd (f s) 74 | in if b1 <= b2 75 | then let zspd3 = add zspd2 (multiplyS spec1 (b1 - s)) 76 | in add zspd3 (multiplyS spec2 (b2 - b1)) 77 | else let zspd3 = add zspd2 (multiplyS spec1 (b2 - s)) 78 | in add zspd3 (multiplyS spec3 (b1 - b2)) 79 | spval = case t of 80 | REFLECTANCE -> 81 | let reflZspd 82 | | cond1 = condfn whiter r g b cyanR blueR greenR 83 | | cond2 = condfn whiter g r b magentaR blueR redR 84 | | otherwise = condfn whiter b g r yellowR greenR redR 85 | in multiplyS reflZspd 0.94 86 | -- 87 | ILLUMINANT -> 88 | let illumZspd 89 | | cond1 = condfn whitei r g b cyanI blueI greenI 90 | | cond2 = condfn whitei g r b magentaI blueI redI 91 | | otherwise = condfn whitei b g r yellowI greenI redI 92 | in multiplyS illumZspd 0.86445 93 | 94 | -- clamp spd value 95 | clampedSpd = clamp spval (0.0, float_max) 96 | lambdaStart = word2Float visibleWavelengthStart 97 | lambdaEnd = word2Float visibleWavelengthEnd 98 | in resampleFromWaves clampedSpd lambdaStart lambdaEnd spectralSampleStride 99 | 100 | -- from a given spd 101 | fromSampledWave :: SampledWavePower -> SpectrumType -> SampledSpectrum 102 | fromSampledWave a b = SSpec {spectrumType = b, sampled = a} 103 | 104 | -- from scalar 105 | fromScalar :: Double -> SpectrumType -> SampledSpectrum 106 | fromScalar a b = SSpec {spectrumType = b, sampled = fromRGB a a a b} 107 | 108 | -- from rgb values 109 | fromRGBModel :: Double -> Double -> Double -> SpectrumType -> SampledSpectrum 110 | fromRGBModel r g b t = SSpec {spectrumType = t, sampled = fromRGB r g b t} 111 | 112 | -- reflectance spectrum from rgb 113 | reflectanceFromRGB :: Double -> Double -> Double -> SampledSpectrum 114 | reflectanceFromRGB r g b = fromRGBModel r g b REFLECTANCE 115 | 116 | -- illuminant spectrum from rgb 117 | illuminantFromRGB :: Double -> Double -> Double -> SampledSpectrum 118 | illuminantFromRGB r g b = fromRGBModel r g b ILLUMINANT 119 | 120 | -- instances 121 | spectrumTypeCheck :: SampledSpectrum -> SampledSpectrum -> (Bool, String) 122 | spectrumTypeCheck a b = ((spectrumType a) == (spectrumType b), 123 | "Spectrum types of sampled spectrums are not the same") 124 | 125 | instance BinaryOps SampledSpectrum where 126 | elementwiseOp str f a b = 127 | let (isSame, s) = spectrumTypeCheck a b 128 | in if isSame == False 129 | then traceStack (s ++ " :: " ++ str) zeroSampledSpectrum 130 | else let ap = sampled a 131 | bp = sampled b 132 | ndata = elementwiseOp str f ap bp 133 | in SSpec { spectrumType = spectrumType a, 134 | sampled = ndata } 135 | 136 | elementwiseScalarOp str f a = let ap = sampled a 137 | ndata = elementwiseScalarOp str f ap 138 | in SSpec { spectrumType = spectrumType a, 139 | sampled = ndata } 140 | -- division 141 | divide a b = 142 | let (isSame, str) = spectrumTypeCheck a b 143 | in if isSame == False 144 | then traceStack (str) zeroSampledSpectrum 145 | else let ap = sampled a 146 | bp = sampled b 147 | ndata = divide ap bp 148 | in SSpec { 149 | spectrumType = spectrumType a, 150 | sampled = ndata 151 | } 152 | 153 | -- 154 | instance Colorable SampledSpectrum where 155 | toXYZ (SSpec {spectrumType = _, 156 | sampled = a} 157 | ) = let wstart = minWavelength a 158 | wend = maxWavelength a 159 | waves = wavelengths a 160 | wsize = lengthNL waves 161 | foldfn acc wave = let (x, y, z) = acc 162 | sx = evaluateWave wave spdX 163 | sy = evaluateWave wave spdY 164 | sz = evaluateWave wave spdZ 165 | -- iv = evaluateWave wave spdIllumD65 166 | iv = 1.0 167 | p = iv * (evaluateWave wave a) 168 | in (x + sx * p, y + sy * p, z + sz * p) 169 | (x, y, z) = foldlNL foldfn (0.0, 0.0, 0.0) waves 170 | ciey = cieYIntegral * (int2Double wsize) 171 | -- lambdaStart = word2Float visibleWavelengthStart 172 | lambdaStart = wstart 173 | -- lambdaEnd = word2Float visibleWavelengthEnd 174 | lambdaEnd = wend 175 | waveScale = (float2Double (lambdaEnd - lambdaStart)) / ciey 176 | in fromList2Vec (x * waveScale) [y * waveScale, z * waveScale] 177 | toRGB a = 178 | let xyzval = toXYZ a 179 | -- rgbval = xyzval 180 | rgbval = xyz2rgb_pbr xyzval 181 | -- rgbval = xyz2rgb_cie xyzval 182 | -- rgbval = xyz2rgb_srgb xyzval 183 | msg x r = let str = "xyz or rgb value contains nans :: XYZ " 184 | str2 = str ++ show x 185 | str3 = str2 ++ " RGB " ++ show r 186 | in str3 187 | check vec = any isNaN (vec2List vec) 188 | in if (check xyzval) || (check rgbval) 189 | then traceStack (msg xyzval rgbval) zeroV3 190 | else rgbval 191 | -------------------------------------------------------------------------------- /src/Material/Scatter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- material module 4 | module Material.Scatter where 5 | 6 | import Math3D.Ray 7 | import Math3D.Vector 8 | import Math3D.CommonOps 9 | 10 | -- color 11 | import Color.ColorInterface 12 | import Spectral.SampledSpectrum 13 | 14 | -- 15 | import Random 16 | import Utility.Utils 17 | import Utility.BaseEnum 18 | 19 | -- 20 | import Hittable.HitRecord 21 | 22 | -- 23 | import Material.Material 24 | import Material.ScatterRecord 25 | 26 | -- pdf 27 | import Pdf.PdfObj 28 | import Pdf.CosinePdf 29 | 30 | -- textures 31 | import Texture.Texture 32 | import Texture.TextureObj 33 | import Texture.SolidColor 34 | 35 | -- thirdparty 36 | import System.Random 37 | 38 | 39 | type Attenuation = ColorRecord 40 | type ScatteredRay = Ray 41 | 42 | class Scatterer a where 43 | scatter :: RandomGen g => g -> a -> Ray -> HitRecord -> ColorFlag -> (g, ScatterRecord, Bool) 44 | emitted :: a -> Double -> Double -> Vector -> WaveVal -> ColorFlag -> ColorRecord 45 | scattering_pdf :: a -> Ray -> HitRecord -> Ray -> Double 46 | 47 | 48 | emptyEmitted :: WaveVal -> ColorFlag -> ColorRecord 49 | emptyEmitted wavelen cflag = 50 | case cflag of 51 | RGB -> ColorRec {model = ColorRGB zeroV3} 52 | Spectral REFLECTANCE -> ColorRec { 53 | model = ColorSpec (ILLUMINANT, (wavelen, 0.0)) 54 | } 55 | Spectral ILLUMINANT -> ColorRec { 56 | model = ColorSpec (ILLUMINANT, (wavelen, 0.0)) 57 | } 58 | 59 | 60 | instance Scatterer Material where 61 | scatter gen a r h f = 62 | case a of 63 | NoMat -> (gen, emptySRec emptyPdfObj, False) 64 | (LambMat la) -> scatter gen la r h f 65 | (MetalMat m) -> scatter gen m r h f 66 | (DielMat m) -> scatter gen m r h f 67 | (LightMat m) -> scatter gen m r h f 68 | (IsotMat m) -> scatter gen m r h f 69 | 70 | emitted a u v p w cflag = 71 | case a of 72 | (LightMat m) -> emitted m u v p w cflag 73 | _ -> emptyEmitted w cflag 74 | 75 | scattering_pdf a r hrec sr = 76 | case a of 77 | NoMat -> 0.0 78 | LambMat la -> scattering_pdf la r hrec sr 79 | MetalMat m -> scattering_pdf m r hrec sr 80 | DielMat d -> scattering_pdf d r hrec sr 81 | LightMat li -> scattering_pdf li r hrec sr 82 | IsotMat im -> scattering_pdf im r hrec sr 83 | 84 | 85 | instance Scatterer Lambertian where 86 | emitted _ _ _ _ w cflag = emptyEmitted w cflag 87 | 88 | scatter !gen !a !inray !hrec _ = 89 | case a of 90 | LambT t -> 91 | let recp = point hrec 92 | recn = pnormal hrec 93 | RandResult (uvec, g) = randomUnitVector gen 94 | sdir = add recn uvec 95 | hu = hUV_u hrec 96 | hv = hUV_v hrec 97 | in if nearZeroVec sdir 98 | then (g, 99 | mkSRecord 100 | (Rd {origin = recp, 101 | direction = recn, 102 | rtime = rtime inray, 103 | wavelength = wavelength inray 104 | }) 105 | (False) 106 | (color t hu hv recp (wavelength inray)) 107 | (PdfCons $! CosNormalPdf recn), True 108 | ) 109 | else (g, 110 | mkSRecord 111 | (Rd {origin = recp, 112 | direction = sdir, 113 | rtime = rtime inray, 114 | wavelength = wavelength inray 115 | }) 116 | (False) 117 | (color t hu hv recp (wavelength inray)) 118 | (PdfCons $! CosNormalPdf recn), True 119 | ) 120 | 121 | 122 | scattering_pdf _ r hrec sr = 123 | let n = pnormal hrec 124 | u = toUnit $! direction sr 125 | cosine = dot n u 126 | in if cosine < 0.0 127 | then 0.0 128 | else cosine / m_pi 129 | 130 | 131 | instance Scatterer Metal where 132 | emitted _ _ _ _ w cflag = emptyEmitted w cflag 133 | 134 | scatter !gen !c !inray !hrec _ = 135 | case c of 136 | (MetT a b) -> 137 | let recp = point hrec 138 | recn = pnormal hrec 139 | hu = hUV_u hrec 140 | hv = hUV_v hrec 141 | indir = toUnit $! direction inray 142 | refdir = reflect indir recn 143 | RandResult (uvec, g) = randomUnitSphere gen 144 | rdir = add refdir (multiplyS uvec b) 145 | in (g, 146 | mkSRecord 147 | (Rd {origin = recp, 148 | direction = rdir, 149 | rtime = rtime inray, 150 | wavelength = wavelength inray 151 | }) 152 | (True) 153 | (color a hu hv recp (wavelength inray)) 154 | (emptyPdfObj), 155 | True) 156 | 157 | scattering_pdf _ _ _ _ = 0.0 158 | 159 | 160 | instance Scatterer Dielectric where 161 | scattering_pdf _ _ _ _ = 0.0 162 | emitted _ _ _ _ w cflag = emptyEmitted w cflag 163 | scatter !gen !a !inray !hrec _ = 164 | case a of 165 | (DielRefIndices rs) -> 166 | let atten = ColorRec {model = ColorRGB $! fromList2Vec 1.0 [1.0, 1.0]} 167 | -- can change with respect to wavelength 168 | ir = head rs 169 | refratio = if isFront hrec 170 | then 1.0 / ir 171 | else ir 172 | udir = toUnit $! direction inray 173 | costheta = min (dot (multiplyS udir (-1.0)) (pnormal hrec)) 1.0 174 | sintheta = sqrt (1.0 - costheta * costheta) 175 | canNotRefract = refratio * sintheta > 1.0 176 | RandResult (rval, g) = randval gen 177 | schlickVal = schlickRef costheta refratio 178 | rdir = if canNotRefract || (schlickVal > rval) 179 | then reflect udir (pnormal hrec) 180 | else refract udir (pnormal hrec) refratio 181 | outray = Rd { origin = point hrec, 182 | direction = rdir, 183 | rtime = rtime inray, 184 | wavelength = wavelength inray 185 | } 186 | in (g, 187 | mkSRecord 188 | outray 189 | True 190 | atten 191 | emptyPdfObj, 192 | True) 193 | 194 | instance Scatterer DiffuseLight where 195 | scattering_pdf _ _ _ _ = 0.0 196 | scatter !gen !a !inray !hrec _ = (gen, emptySRec emptyPdfObj, False) 197 | emitted b u v p wave _ = 198 | case b of 199 | DLightEmitTextureCons a -> color a u v p wave 200 | 201 | instance Scatterer Isotropic where 202 | scattering_pdf _ _ _ _ = 0.0 203 | emitted _ _ _ _ w cflag = emptyEmitted w cflag 204 | scatter !gen !b !inray !hrec _ = 205 | case b of 206 | IsotTexture a -> 207 | let RandResult (uvec, g) = randomUnitSphere gen 208 | recp = point hrec 209 | hu = hUV_u hrec 210 | hv = hUV_v hrec 211 | outray = Rd {origin = recp, 212 | direction = uvec, 213 | rtime = rtime inray, 214 | wavelength = wavelength inray 215 | } 216 | atten = color a hu hv recp (wavelength inray) 217 | in (g, 218 | mkSRecord 219 | outray 220 | True 221 | atten 222 | emptyPdfObj, 223 | True) 224 | --------------------------------------------------------------------------------