From 30b557eeda2783ff09c4c2d63461d31fcb5770c9 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Mon, 20 Jul 2015 00:45:04 +0200 Subject: [PATCH] made a stack version for hglmandel --- .gitignore | 4 + LICENSE | 3 + Setup.hs | 2 + hglmandel.cabal | 30 ++++ src/ExtComplex.hs | 37 +++++ src/Mandel.hs | 15 ++ src/Mandelbulb.lhs | 220 ++++++++++++++++++++++++++ src/YGL.hs | 384 +++++++++++++++++++++++++++++++++++++++++++++ stack.yaml | 5 + 9 files changed, 700 insertions(+) create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 hglmandel.cabal create mode 100644 src/ExtComplex.hs create mode 100644 src/Mandel.hs create mode 100644 src/Mandelbulb.lhs create mode 100644 src/YGL.hs create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index b2c2064..a39d61e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,9 @@ *.o *.hi *~ +*.swp Mandelbulb hglmandel +.stack-work/ +dist/ +.hdevtools.sock diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5bb212a --- /dev/null +++ b/LICENSE @@ -0,0 +1,3 @@ +Public Domain. Do what you want with it. Just don't be a dick. + +Also, I can't give you what I've done. So you are forced to remember I'm at the source of this repo. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hglmandel.cabal b/hglmandel.cabal new file mode 100644 index 0000000..339db9e --- /dev/null +++ b/hglmandel.cabal @@ -0,0 +1,30 @@ +-- Initial hglmandel.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: hglmandel +version: 0.1.0.0 +synopsis: 3D Fractals +-- description: +homepage: http://yannesposito.com/Scratch/fr/blog/Haskell-OpenGL-Mandelbrot/ +license: PublicDomain +license-file: LICENSE +author: Yann Esposito (Yogsototh) +maintainer: Yann.Esposito@gmail.com +-- copyright: +category: Graphics +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable hglmandel + main-is: Mandelbulb.lhs + -- other-modules: + -- other-extensions: + build-depends: base + , containers + , GLUT + , OpenGL + , OpenGLRaw + hs-source-dirs: src + ghc-options: -Wall -dynamic + default-language: Haskell2010 diff --git a/src/ExtComplex.hs b/src/ExtComplex.hs new file mode 100644 index 0000000..caba8d0 --- /dev/null +++ b/src/ExtComplex.hs @@ -0,0 +1,37 @@ +module ExtComplex where + +import Graphics.Rendering.OpenGL + +-- This time I use unpacked strict data type +-- Far faster when compiled. +data ExtComplex = C {-# UNPACK #-} !GLfloat + {-# UNPACK #-} !GLfloat + {-# UNPACK #-} !GLfloat + deriving (Show,Eq) + +instance Num ExtComplex where + -- The shape of the 3D mandelbrot + -- will depend on this formula + (C x y z) * (C x' y' z') = C (x*x' - y*y' - z*z') + (x*y' + y*x' + z*z') + (x*z' + z*x' ) + -- The rest is straightforward + fromInteger n = C (fromIntegral n) 0 0 + (C x y z) + (C x' y' z') = C (x+x') (y+y') (z+z') + abs (C x y z) = C (sqrt (x*x + y*y + z*z)) 0 0 + signum (C x y z) = C (signum x) (signum y) (signum z) + +extcomplex :: GLfloat -> GLfloat -> GLfloat -> ExtComplex +extcomplex x y z = C x y z + +real :: ExtComplex -> GLfloat +real (C x _ _) = x + +im :: ExtComplex -> GLfloat +im (C _ y _) = y + +strange :: ExtComplex -> GLfloat +strange (C _ _ z) = z + +magnitude :: ExtComplex -> GLfloat +magnitude = real.abs diff --git a/src/Mandel.hs b/src/Mandel.hs new file mode 100644 index 0000000..62787da --- /dev/null +++ b/src/Mandel.hs @@ -0,0 +1,15 @@ +-- The Mandelbrot function +module Mandel (mandel) where + +import ExtComplex +import Graphics.Rendering.OpenGL.Raw.Types (GLfloat) + +mandel :: GLfloat -> GLfloat -> GLfloat -> Int -> Int +mandel r i s nbIterations = + f (extcomplex r i s) 0 nbIterations + where + f :: ExtComplex -> ExtComplex -> Int -> Int + f _ _ 0 = 0 + f c z n = if (magnitude z > 2 ) + then n + else f c ((z*z)+c) (n-1) diff --git a/src/Mandelbulb.lhs b/src/Mandelbulb.lhs new file mode 100644 index 0000000..90b9e04 --- /dev/null +++ b/src/Mandelbulb.lhs @@ -0,0 +1,220 @@ + ## Optimization + +Our code architecture feel very clean. +All the meaningful code is in our main file and all display details are +externalized. +If you read the code of `YGL.hs`, you'll see I didn't made everything perfect. +For example, I didn't finished the code of the lights. +But I believe it is a good first step and it will be easy to go further. +Unfortunately the program of the preceding session is extremely slow. +We compute the Mandelbulb for each frame now. + +Before our program structure was: + + +Constant Function -> Constant List of Triangles -> Display + + +Now we have + + +Main loop -> World -> Function -> List of Objects -> Atoms -> Display + + +The World state could change. +The compiler can no more optimize the computation for us. +We have to manually explain when to redraw the shape. + +To optimize we must do some things in a lower level. +Mostly the program remains the same, +but it will provide the list of atoms directly. + +
+ +> import YGL -- Most the OpenGL Boilerplate +> import Mandel -- The 3D Mandelbrot maths +> +> -- Centralize all user input interaction +> inputActionMap :: InputMap World +> inputActionMap = inputMapFromList [ +> (Press ' ' , switchRotation) +> ,(Press 'k' , rotate xdir 5) +> ,(Press 'i' , rotate xdir (-5)) +> ,(Press 'j' , rotate ydir 5) +> ,(Press 'l' , rotate ydir (-5)) +> ,(Press 'o' , rotate zdir 5) +> ,(Press 'u' , rotate zdir (-5)) +> ,(Press 'f' , translate xdir 0.1) +> ,(Press 's' , translate xdir (-0.1)) +> ,(Press 'e' , translate ydir 0.1) +> ,(Press 'd' , translate ydir (-0.1)) +> ,(Press 'z' , translate zdir 0.1) +> ,(Press 'r' , translate zdir (-0.1)) +> ,(Press '+' , zoom 1.1) +> ,(Press '-' , zoom (1/1.1)) +> ,(Press 'h' , resize 2.0) +> ,(Press 'g' , resize (1/2.0)) +> ] + +
+ +> data World = World { +> angle :: Point3D +> , anglePerSec :: Scalar +> , scale :: Scalar +> , position :: Point3D +> , box :: Box3D +> , told :: Time +> -- We replace shape by cache +> , cache :: [YObject] +> } + + +> instance DisplayableWorld World where +> winTitle _ = "The YGL Mandelbulb" +> camera w = Camera { +> camPos = position w, +> camDir = angle w, +> camZoom = scale w } +> -- We update our objects instanciation +> objects = cache + +
+ +> xdir :: Point3D +> xdir = makePoint3D (1,0,0) +> ydir :: Point3D +> ydir = makePoint3D (0,1,0) +> zdir :: Point3D +> zdir = makePoint3D (0,0,1) +> +> rotate :: Point3D -> Scalar -> World -> World +> rotate dir angleValue world = +> world { +> angle = angle world + (angleValue -*< dir) } +> +> switchRotation :: World -> World +> switchRotation world = +> world { +> anglePerSec = if anglePerSec world > 0 then 0 else 5.0 } +> +> translate :: Point3D -> Scalar -> World -> World +> translate dir len world = +> world { +> position = position world + (len -*< dir) } +> +> zoom :: Scalar -> World -> World +> zoom z world = world { +> scale = z * scale world } + +> main :: IO () +> main = yMainLoop inputActionMap idleAction initialWorld + +
+ +Our initial world state is slightly changed: + +> -- We initialize the world state +> -- then angle, position and zoom of the camera +> -- And the shape function +> initialWorld :: World +> initialWorld = World { +> angle = makePoint3D (30,30,0) +> , anglePerSec = 5.0 +> , position = makePoint3D (0,0,0) +> , scale = 1.0 +> , box = Box3D { minPoint = makePoint3D (0-eps, 0-eps, 0-eps) +> , maxPoint = makePoint3D (0+eps, 0+eps, 0+eps) +> , resolution = 0.02 } +> , told = 0 +> -- We declare cache directly this time +> , cache = objectFunctionFromWorld initialWorld +> } +> where eps=2 + +The use of `eps` is a hint to make a better zoom by computing with the right bounds. + +We use the `YGL.getObject3DFromShapeFunction` function directly. +This way instead of providing `XYFunc`, we provide directly a list of Atoms. + +> objectFunctionFromWorld :: World -> [YObject] +> objectFunctionFromWorld w = [Atoms atomList] +> where atomListPositive = +> getObject3DFromShapeFunction +> (shapeFunc (resolution (box w))) (box w) +> atomList = atomListPositive ++ +> map negativeTriangle atomListPositive +> negativeTriangle (ColoredTriangle (p1,p2,p3,c)) = +> ColoredTriangle (negz p1,negz p3,negz p2,c) +> where negz (P (x,y,z)) = P (x,y,-z) + +We know that resize is the only world change that necessitate to +recompute the list of atoms (triangles). +Then we update our world state accordingly. + +> resize :: Scalar -> World -> World +> resize r world = +> tmpWorld { cache = objectFunctionFromWorld tmpWorld } +> where +> tmpWorld = world { box = (box world) { +> resolution = sqrt ((resolution (box world))**2 * r) }} + +All the rest is exactly the same. + +
+ +> idleAction :: Time -> World -> World +> idleAction tnew world = +> world { +> angle = angle world + (delta -*< zdir) +> , told = tnew +> } +> where +> delta = anglePerSec world * elapsed / 1000.0 +> elapsed = fromIntegral (tnew - (told world)) +> +> shapeFunc :: Scalar -> Function3D +> shapeFunc res x y = +> let +> z = maxZeroIndex (ymandel x y) 0 1 20 +> in +> if and [ maxZeroIndex (ymandel (x+xeps) (y+yeps)) 0 1 20 < 0.000001 | +> val <- [res], xeps <- [-val,val], yeps<-[-val,val]] +> then Nothing +> else Just (z,colorFromValue 0) +> +> colorFromValue :: Point -> Color +> colorFromValue n = +> let +> t :: Point -> Scalar +> t i = 0.0 + 0.5*cos( i /10 ) +> in +> makeColor (t n) (t (n+5)) (t (n+10)) +> +> -- given f min max nbtest, +> -- considering +> -- - f is an increasing function +> -- - f(min)=0 +> -- - f(max)≠0 +> -- then maxZeroIndex f min max nbtest returns x such that +> -- f(x - ε)=0 and f(x + ε)≠0 +> -- where ε=(max-min)/2^(nbtest+1) +> maxZeroIndex :: (Fractional a,Num a,Num b,Eq b) => +> (a -> b) -> a -> a -> Int -> a +> maxZeroIndex _ minval maxval 0 = (minval+maxval)/2 +> maxZeroIndex func minval maxval n = +> if func medpoint /= 0 +> then maxZeroIndex func minval medpoint (n-1) +> else maxZeroIndex func medpoint maxval (n-1) +> where medpoint = (minval+maxval)/2 +> +> ymandel :: Point -> Point -> Point -> Point +> ymandel x y z = fromIntegral (mandel x y z 64) / 64 + +
+ +And you can also consider minor changes in the `YGL.hs` source file. + +- [`YGL.hs`](code/06_Mandelbulb/YGL.hs), the 3D rendering framework +- [`Mandel`](code/06_Mandelbulb/Mandel.hs), the mandel function +- [`ExtComplex`](code/06_Mandelbulb/ExtComplex.hs), the extended complexes diff --git a/src/YGL.hs b/src/YGL.hs new file mode 100644 index 0000000..0cddeb5 --- /dev/null +++ b/src/YGL.hs @@ -0,0 +1,384 @@ +{- +The module YGL will contains most boilerplate +And display details. + +To make things even nicer, we should separate +this file in many different parts. +Typically separate the display function. + +-} +module YGL ( + -- Here is declared our interface with external files + -- that will include our YGL module + + -- Declarations related to data types + Point -- the 1 dimension point type + , Time -- the type for the time + , Scalar -- the type for scalar values + , Color -- the type for color (3 scalars) + , Point3D (..) -- A 3D point type (3 Points) + , makePoint3D -- helper (x,y,z) -> Point3D + , (-*<) -- scalar product on Point3D a -*< (x,y,z) = (ax,ay,az) + , Function3D -- Point -> Point -> Maybe (Point,Color) + , xpoint, ypoint, zpoint + , Atom (..) -- The Atom object (colored triangles for now) + + -- Your world state must be an instance + -- of the DisplayableWorld type class + , DisplayableWorld (..) + -- Datas related to DisplayableWorld + , Camera (..) + , YObject (..) -- 3D Objects to display + , Box3D (..) -- Some bounded 3D box + , getObject3DFromShapeFunction + , makeBox -- helper to make a box + , hexColor -- Color from hexadecimal string + , makeColor -- make color from RGB values + + -- Interface related to user input + , InputMap + , UserInput (Press,Ctrl,Alt,CtrlAlt) + , inputMapFromList + + -- The main loop function to call + , yMainLoop +) where + +-- A bunch of imports +import Numeric (readHex) -- to read hexadecimal values + +-- Import of OpenGL and GLUT +-- but, I use my own Color type, therefore I hide the definition +-- of Color inside GLUT and OpenGL packages +import Graphics.Rendering.OpenGL hiding (Color) +import Graphics.UI.GLUT hiding (Color) +import Data.IORef + +-- I use Map to deal with user interaction +import qualified Data.Map as Map + +-- Some standard stuff +import Control.Monad (when) +import Data.Maybe (isNothing) + +{-- Things start to be complex here. +- Just take the time to follow me. +--} + +-- | A 1D point +type Point = GLfloat +-- | A Scalar value +type Scalar = GLfloat +-- | The time type (currently its Int) +type Time = Int +-- | A 3D Point mainly '(x,y,z)' +data Point3D = P (Point,Point,Point) deriving (Eq,Show,Read) +type Color = Color3 Scalar + +-- Get x (resp. y, z) coordinate of a 3D point +xpoint :: Point3D -> Point +xpoint (P (x,_,_)) = x +ypoint :: Point3D -> Point +ypoint (P (_,y,_)) = y +zpoint :: Point3D -> Point +zpoint (P (_,_,z)) = z + +-- Create a Point3D element from a triplet +makePoint3D :: (Point,Point,Point) -> Point3D +makePoint3D = P + +-- Make Point3D an instance of Num +instance Num Point3D where + (+) (P (ax,ay,az)) (P (bx,by,bz)) = P (ax+bx,ay+by,az+bz) + (-) (P (ax,ay,az)) (P (bx,by,bz)) = P (ax-bx,ay-by,az-bz) + (*) (P (ax,ay,az)) (P (bx,by,bz)) = P ( ay*bz - az*by + , az*bx - ax*bz + , ax*by - ay*bx ) + abs (P (x,y,z)) = P (abs x,abs y, abs z) + signum (P (x,y,z)) = P (signum x, signum y, signum z) + fromInteger i = P (fromInteger i, 0, 0) + +-- The scalar product +infixr 5 -*< +(-*<) :: Scalar -> Point3D -> Point3D +(-*<) s p = P (s*xpoint p, s*ypoint p, s*zpoint p) + +-- Used internally to convert point3D to different types +toGLVector3 :: Point3D -> Vector3 GLfloat +toGLVector3 (P(x,y,z)) = Vector3 x y z + +toGLVertex3 :: Point3D -> Vertex3 GLfloat +toGLVertex3 (P(x,y,z)) = Vertex3 x y z + +toGLNormal3 :: Point3D -> Normal3 GLfloat +toGLNormal3 (P(x,y,z)) = Normal3 x y z + +-- | The Box3D type represent a 3D bounding box +-- | Note if minPoint = (x,y,z) and maxPoint = (x',y',z') +-- | Then to have a non empty box you must have +-- | x (Point,Point,Point) -> Scalar -> Box3D +makeBox mini maxi res = Box3D { + minPoint = makePoint3D mini + , maxPoint = makePoint3D maxi + , resolution = res } + +-- | A Triangle3D is simply 3 points and a color +type Triangle3D = (Point3D,Point3D,Point3D,Color) + +-- | The type Atom is the atom for our display here we'll only use triangles. +-- | For a general purpose library we should add many other different atoms +-- | corresponding to Quads for example. +data Atom = ColoredTriangle Triangle3D + +-- | A Function3D is simply a function for each x,y associate a z and a color +-- | If undefined at point (x,y), it returns Nothing. +type Function3D = Point -> Point -> Maybe (Point,Color) + +-- | Our objects that will be displayed +-- | Wether a function3D delimited by a Box +-- | or a list of Atoms +data YObject = XYFunc Function3D Box3D + | Atoms [Atom] + +-- | The function atoms retrieve the list of atoms from an YObject +atoms :: YObject -> [Atom] +atoms (XYFunc f b) = getObject3DFromShapeFunction f b +atoms (Atoms atomList) = atomList + +-- | We decalre the input map type we need here +-- | It is our API +-- | I don't use Mouse but it can be easily added +type InputMap worldType = Map.Map UserInput (worldType -> worldType) +data UserInput = Press Char | Ctrl Char | Alt Char | CtrlAlt Char + deriving (Eq,Ord,Show,Read) + +-- | A displayable world is a type for which +-- | ther exists a function that provide sufficient informations +-- | to provide a camera, lights, objects and a window title. +class DisplayableWorld world where + camera :: world -> Camera + camera _ = defaultCamera + lights :: world -> [Light] + lights _ = [] + objects :: world -> [YObject] + objects _ = [] + winTitle :: world -> String + winTitle _ = "YGL" + +-- | the Camera type to know how to +-- | Transform the scene to see the right view. +data Camera = Camera { + camPos :: Point3D + , camDir :: Point3D + , camZoom :: Scalar } + +-- | A default initial camera +defaultCamera :: Camera +defaultCamera = Camera { + camPos = makePoint3D (0,0,0) + , camDir = makePoint3D (0,0,0) + , camZoom = 1 } + + +-- | Given a shape function and a delimited Box3D +-- | return a list of Atoms (here only colored triangles) to be displayed +getObject3DFromShapeFunction :: Function3D -> Box3D -> [Atom] +getObject3DFromShapeFunction shape box = do + x <- [xmin,xmin+res..xmax] + y <- [ymin,ymin+res..ymax] + let + neighbors = [(x,y),(x+res,y),(x+res,y+res),(x,y+res)] + -- zs are 3D points with found depth and color + -- zs :: [ (Point,Point,Point,Maybe (Point,Color) ] + zs = map (\(u,v) -> (u,v,shape u v)) neighbors + -- ps are 3D opengl points + color value + ps = zs + -- If the point diverged too fast, don't display it + if any (\(_,_,z) -> isNothing z) zs + then [] + -- Draw two triangles + -- 3 - 2 + -- | / | + -- 0 - 1 + -- The order is important + else + [ makeAtom (ps!!0) (ps!!2) (ps!!1) + , makeAtom (ps!!0) (ps!!3) (ps!!2) ] + where + makeAtom (p0x,p0y,Just (p0z,c0)) (p1x,p1y,Just (p1z,_)) (p2x,p2y,Just (p2z,_)) = + ColoredTriangle (makePoint3D (p0x,p0y,p0z) + ,makePoint3D (p1x,p1y,p1z) + ,makePoint3D (p2x,p2y,p2z) + ,c0) + makeAtom _ _ _ = error "Somethings wrong here" + + -- some naming to make it + -- easier to read + xmin = xpoint $ minPoint box + xmax = xpoint $ maxPoint box + ymin = ypoint $ minPoint box + ymax = ypoint $ maxPoint box + res = resolution box + +-- | Get the user input map from a list +inputMapFromList :: (DisplayableWorld world) => + [(UserInput,world -> world)] -> InputMap world +inputMapFromList = Map.fromList + +{-- +- We set our mainLoop function +- As you can see the code is _not_ pure +- and not even functionnal friendly! +- But when called, +- it will look like a pure functional function. +--} +yMainLoop :: (DisplayableWorld worldType) => + -- the mapping user input / world + InputMap worldType + -- function that modify the world + -> (Time -> worldType -> worldType) + -- the world state of type worldType + -> worldType + -- into IO () for obvious reason + -> IO () +yMainLoop inputActionMap + worldTranformer + world = do + -- The boilerplate + _ <- getArgsAndInitialize + initialDisplayMode $= + [WithDepthBuffer,DoubleBuffered,RGBMode] + _ <- createWindow $ winTitle world + depthFunc $= Just Less + windowSize $= Size 500 500 + -- The state variables for the world (I know it feels BAD) + worldRef <- newIORef world + -- Action to call when waiting + idleCallback $= Just (idle worldTranformer worldRef) + -- the keyboard will update the world + keyboardMouseCallback $= + Just (keyboardMouse inputActionMap worldRef) + -- We generate one frame using the callback + displayCallback $= display worldRef + -- let OpenGL resize normal vectors to unity + normalize $= Enabled + shadeModel $= Smooth + -- Lights (in a better version should be put elsewhere) + lighting $= Enabled + ambient (Light 0) $= Color4 0.5 0.5 0.5 1 + diffuse (Light 0) $= Color4 1 1 1 1 + light (Light 0) $= Enabled + pointSmooth $= Enabled + + colorMaterial $= Just (Front,AmbientAndDiffuse) + materialAmbient Front $= Color4 0.0 0.0 0.0 1 + materialDiffuse Front $= Color4 0.0 0.0 0.0 1 + materialSpecular Front $= Color4 1 1 1 1 + materialEmission Front $= Color4 0.0 0.0 0.0 1 + materialShininess Front $= 96 + -- We enter the main loop + mainLoop + +-- When no user input entered do nothing +idle :: (Time -> worldType -> worldType) -> IORef worldType -> IO () +idle worldTranformer world = do + w <- get world + t <- get elapsedTime + world $= worldTranformer t w + postRedisplay Nothing + +-- | Get User Input +-- | both cleaner, terser and more expendable than the preceeding code +keyboardMouse :: InputMap a -> IORef a + -> Key -> KeyState -> Modifiers -> Position -> IO() +keyboardMouse input world key state _ _ = + when (state == Down) $ + let + charFromKey (Char c) = c + -- To complete if you want to finish it + charFromKey _ = '#' + + transformator = Map.lookup (Press (charFromKey key)) input + in + mayTransform transformator + where + mayTransform Nothing = return () + mayTransform (Just transform) = do + w <- get world + world $= transform w + + +-- | The function that will display datas +display :: (HasGetter t world, DisplayableWorld world) => t -> IO () +display worldRef = do + -- BEWARE UGLINESS!!!! + -- SHOULD NEVER MODIFY worldRef HERE!!!! + -- + -- I SAID NEVER. + w <- get worldRef + -- NO REALLY, NEVER!!!! + -- If someone write a line starting by + -- w $= ... Shoot him immediately in the head + -- and refere to competent authorities + let cam = camera w + -- set the background color (dark solarized theme) + -- Could also be externalized to world state + clearColor $= Color4 0 0.1686 0.2117 1 + clear [ColorBuffer,DepthBuffer] + -- Transformation to change the view + loadIdentity -- reset any transformation + -- tranlate + translate $ toGLVector3 (camPos cam) + -- zoom + scale (camZoom cam) (camZoom cam) (camZoom cam) + -- rotate + rotate (xpoint (camDir cam)) $ Vector3 1.0 0.0 (0.0::GLfloat) + rotate (ypoint (camDir cam)) $ Vector3 0.0 1.0 (0.0::GLfloat) + rotate (zpoint (camDir cam)) $ Vector3 0.0 0.0 (1.0::GLfloat) + -- Now that all transformation were made + -- We create the object(s) + _ <- preservingMatrix $ mapM drawObject (objects w) + swapBuffers -- refresh screen + +-- Hexa style colors +scalarFromHex :: String -> Scalar +scalarFromHex = (/256) . fst . head . readHex + +-- | Color from CSS style color string +hexColor :: String -> Color +hexColor ('#':rd:ru:gd:gu:bd:bu:[]) = Color3 (scalarFromHex [rd,ru]) + (scalarFromHex [gd,gu]) + (scalarFromHex [bd,bu]) +hexColor ('#':r:g:b:[]) = hexColor ['#',r,r,g,g,b,b] +hexColor _ = error "Bad color!!!!" + +-- | Helper to make a color from RGB scalar values +makeColor :: Scalar -> Scalar -> Scalar -> Color +makeColor = Color3 + +-- | Where the drawing occurs +drawObject :: YObject -> IO() +drawObject shape = renderPrimitive Triangles $ + mapM_ drawAtom (atoms shape) + +-- simply draw an Atom +drawAtom :: Atom -> IO () +drawAtom atom@(ColoredTriangle (p0,p1,p2,c)) = do + color c + normal $ toGLNormal3 (getNormal atom) + vertex $ toGLVertex3 p0 + vertex $ toGLVertex3 p1 + vertex $ toGLVertex3 p2 + +-- | get the normal vector of an Atom +-- I don't normalize it; it is done by OpenGL +-- in main with 'normalize $= Enabled' +getNormal :: Atom -> Point3D +getNormal (ColoredTriangle (p0,p1,p2,_)) = (p1 - p0) * (p2 - p0) diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..6252712 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: lts-2.17