diff --git a/SnowGlobe.hs b/SnowGlobe.hs --- a/SnowGlobe.hs +++ b/SnowGlobe.hs @@ -1,11 +1,10 @@ -- SnowGlobe -- randomized fractal snowflakes demo --- (GPL3+) 2012 Claude Heiland-Allen +-- (GPL3+) 2012,2014 Claude Heiland-Allen -- usage: snowglobe -- 'f' toggles full screen, 'shift-R' toggles record, any other key to quit --- tested with: ghc-7.0.4, ghc-7.4-rc1, ghc-7.4.2, ghc-7.6.2 +-- tested with: ghc-7.0.4, ghc-7.4-rc1, ghc-7.4.2, ghc-7.6.2, ghc-7.8.2 -import Numeric.LinearAlgebra hiding (i, reshape) -import qualified Numeric.LinearAlgebra as L +import Vector hiding (i) import Graphics.UI.GLUT hiding (scale, FramebufferObject) import qualified Graphics.UI.GLUT as GL import Graphics.Rendering.OpenGL.Raw @@ -13,7 +12,8 @@ , gl_UNSIGNED_BYTE, gl_FALSE, glClampColor, glGenerateMipmap , gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR, gl_CLAMP_FRAGMENT_COLOR , glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D - , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, glUniformMatrix3fv + , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, glUniformMatrix3fv, gl_ALPHA + , glGetTexImage ) import Control.Exception (evaluate) import Control.Monad (forM_, replicateM, when) @@ -24,12 +24,14 @@ import qualified Data.Map as M import qualified Data.Set as S import System.Exit (exitSuccess) -import System.IO (hPutStrLn, stderr, stdout) +import System.IO (hPutStrLn, stderr, stdout, hPutStr, withBinaryFile, IOMode(WriteMode), hPutBuf) import System.Random (randomRIO) -import Unsafe.Coerce (unsafeCoerce) -- for OpenGL newtypes +import Unsafe.Coerce (unsafeCoerce) -- for OpenGL uniform newtype import Foreign (alloca, peek, nullPtr, withArray) import Graphics.Rendering.OpenGL.Capture (capturePPM) -import Data.ByteString (hPut) +import Data.ByteString as BS (hPut, pack) +import Foreign (Ptr, allocaArray) +import Data.Word (Word8) shader :: Maybe String -> Maybe String -> IO Program shader mV mF = do @@ -38,7 +40,7 @@ Nothing -> return [] Just v -> do vert <- createShader VertexShader - shaderSource vert $= [ v ] + shaderSourceBS vert $= BS.pack (map (toEnum . fromEnum) v) compileShader vert msg <- get (shaderInfoLog vert) when (not (null msg)) $ hPutStrLn stderr msg @@ -47,7 +49,7 @@ Nothing -> return [] Just f -> do frag <- createShader FragmentShader - shaderSource frag $= [ f ] + shaderSourceBS frag $= BS.pack (map (toEnum . fromEnum) f) compileShader frag msg <- get (shaderInfoLog frag) when (not (null msg)) $ hPutStrLn stderr msg @@ -59,21 +61,10 @@ return p type N = Int -type R = Double -type V = L.Vector R -type M = L.Matrix R sum' :: Num a => [a] -> a sum' = foldl' (+) 0 -{-# RULES "realToFrac/glDouble" realToFrac = unsafeCoerceGLdouble #-} -unsafeCoerceGLdouble :: Double -> GLdouble -unsafeCoerceGLdouble = unsafeCoerce - -{-# RULES "realToFrac/glFloat" realToFrac = unsafeCoerceGLfloat #-} -unsafeCoerceGLfloat :: Float -> GLfloat -unsafeCoerceGLfloat = unsafeCoerce - size :: N size = 2048 @@ -92,19 +83,19 @@ data SnowGlobe = SnowGlobe { pInitial :: Program, pInitial'er, pInitial'rho :: UniformLocation , pStep :: Program, pStep'er, pStep'ts, pStep'src :: UniformLocation - , pColour :: Program, pColour'src, pColour'speed :: UniformLocation + , pColour :: Program, pColour'src, pColour'speed, pColour'colour :: UniformLocation , tPing, tPong :: TextureObject, fBuffer :: FramebufferObject , sFlakes :: [Flake], sTextures :: Map N TextureObject , wSize :: Size, wFullScreen :: Maybe Size , sRenderFlake :: IO Render, sNextName :: N - , sRecord :: Bool + , sRecord, sRecordFlakes :: Bool } data Flake = Flake { flakeName :: !N , flakeTime :: !R - , flakePosition :: !V - , flakeVelocity :: !V + , flakePosition :: !V2 + , flakeVelocity :: !V2 } flakeMass :: Flake -> R @@ -113,30 +104,34 @@ flakeSize :: Flake -> R flakeSize f = sin (pi * flakeTime f) -flakeForce :: Flake -> V -> V +flakeForce :: Flake -> V2 -> V2 flakeForce f p = - let d = p - flakePosition f - [x,y] = toList d + let d@(V2 x y) = p ^-^ flakePosition f m = let d2 = x * x + y * y in d2 * d2 - in scale (flakeMass f / m) d + in (flakeMass f / m) *^ d flakeUpdate :: R -> [Flake] -> Flake -> Flake flakeUpdate dt fs f = f { flakeTime = flakeTime f + dt / 2 - , flakePosition = flakePosition f + scale dt (flakeVelocity f) - , flakeVelocity = mapVector ((* maxSpeed) . tanh . (/ maxSpeed)) $ 0.999 * (flakeVelocity f + scale (dt / flakeMass f) (flakeField fs (flakePosition f))) + , flakePosition = flakePosition f ^+^ (dt *^ flakeVelocity f) + , flakeVelocity = mapVector ((* maxSpeed) . tanh . (/ maxSpeed)) $ 0.999 *^ (flakeVelocity f ^+^ ((dt / flakeMass f) *^ (flakeField fs (flakePosition f)))) } -flakeField :: [Flake] -> V -> V -flakeField fs p = sum' [ flakeForce f (p + d) | f <- fs, p /= flakePosition f, dx <- [-2,0,2], dy <- [-2,0,2], let d = 2|>[dx,dy] ] +mapVector :: (R -> R) -> V2 -> V2 +mapVector f (V2 x y) = V2 (f x) (f y) +flakeField :: [Flake] -> V2 -> V2 +flakeField fs p = foldl' (^+^) o [ flakeForce f (p ^+^ d) | f <- fs, p /= flakePosition f, dx <- [-2,0,2], dy <- [-2,0,2], let d = V2 dx dy ] + flakeSpawn :: [Flake] -> N -> IO Flake flakeSpawn fs name = do xs <- replicateM 32 $ randomRIO (-1, 1) ys <- replicateM 32 $ randomRIO (-1, 1) - let ps = zipWith (\x y -> 2|>[x,y]) xs ys + let ps = zipWith V2 xs ys p = fst . minimumBy (comparing snd) . map (\p' -> (p', norm2 (flakeField fs p'))) $ ps - return Flake{ flakeName = name, flakeTime = 0, flakePosition = p, flakeVelocity = 0 } + return Flake{ flakeName = name, flakeTime = 0, flakePosition = p, flakeVelocity = o } + where + norm2 (V2 x y) = x * x + y * y flakesUpdate :: R -> [Flake] -> [Flake] flakesUpdate dt fs = @@ -177,7 +172,7 @@ return $ Step (flakeRenderPass sR ts passes passes) -- multi step passes -flakeRenderPass :: IORef SnowGlobe -> [M] -> N -> N -> IO Render +flakeRenderPass :: IORef SnowGlobe -> [M3] -> N -> N -> IO Render flakeRenderPass sR _ passes 0 = flakeRenderFinish sR passes flakeRenderPass sR ts passes n = do s0 <- readIORef sR @@ -187,7 +182,7 @@ currentProgram $= Just (pStep s0) uniform (pStep'er s0) $= TexCoord1 (realToFrac er :: GLfloat) uniform (pStep'src s0) $= TexCoord1 (0 :: GLint) - withArray (map ((realToFrac :: Float -> GLfloat) . (realToFrac :: Double -> Float)) . concat . concatMap L.toLists $ ts) $ glUniformMatrix3fv (unsafeCoerce $ pStep'ts s0) 6 1 + withArray (map ((realToFrac :: Float -> GLfloat) . (realToFrac :: Double -> Float)) . concatMap matrixToList $ ts) $ glUniformMatrix3fv (unsafeCoerce $ pStep'ts s0) 6 1 bindFBO (fBuffer s0) (tPong s0) textureBinding Texture2D $= Just (tPing s0) unitQuad @@ -199,6 +194,9 @@ then return $ Step (flakeRenderPass sR ts passes (n - 1)) else flakeRenderPass sR ts passes (n - 1) +matrixToList :: M3 -> [R] +matrixToList (M3 a b c d e f g h i) = [a,b,c,d,e,f,g,h,i] + -- colourize pass flakeRenderFinish :: IORef SnowGlobe -> N -> IO Render flakeRenderFinish sR passes = do @@ -212,6 +210,7 @@ currentProgram $= Just (pColour s0) uniform (pColour'src s0) $= TexCoord1 (0 :: GLint) uniform (pColour'speed s0) $= TexCoord1 (1 / fromIntegral passes :: GLfloat) + uniform (pColour'colour s0) $= TexCoord3 1 1 (1 :: GLfloat) fullQuad currentProgram $= Nothing unbindFBO @@ -220,13 +219,12 @@ textureBinding Texture2D $= Nothing return $ Done t -transformRST :: R -> R -> V -> M -transformRST a l p = (3><3)[ c, s, x, -s, c, y, 0, 0, 1 ] - where x:y:_ = toList p - c = l * cos a +transformRST :: R -> R -> V2 -> M3 +transformRST a l (V2 x y) = M3 c s x (-s) c y 0 0 1 + where c = l * cos a s = l * sin a -flakeTransforms :: [R] -> [(R, M)] +flakeTransforms :: [R] -> [(R, M3)] flakeTransforms [a,b,c,d] = [(la,inv ta),(lb,inv tb),(lc,inv tc1),(ld,inv td1),(lc,inv tc2),(ld,inv td2)] where lx = a + b @@ -235,8 +233,8 @@ lb = b / lx lc = c / ly ld = d / ly - u = 2|> [0, 0] - v = 2|> [0, la] + u = V2 0 0 + v = V2 0 la l = pi / 3 ll = 2 * pi / 3 r = -l @@ -306,6 +304,7 @@ pColour' <- shader Nothing (Just $ unlines [ "uniform sampler2D src;" , "uniform float speed;" + , "uniform vec3 colour;" , "" , "void main() {" , " vec2 p = gl_TexCoord[0].xy;" @@ -323,11 +322,12 @@ , " }" , " n *= n;" , " n *= n;" - , " gl_FragData[0] = vec4(vec3(1.0), n);" + , " gl_FragData[0] = vec4(colour, n);" , "}" ]) pColour'src' <- get $ uniformLocation pColour' "src" pColour'speed'<- get $ uniformLocation pColour' "speed" + pColour'colour'<- get $ uniformLocation pColour' "colour" tPing' <- newTex size tPong' <- newTex size fBuffer' <- newFBO @@ -337,11 +337,11 @@ sR <- newIORef SnowGlobe { pInitial = pInitial', pInitial'er = pInitial'er', pInitial'rho = pInitial'rho' , pStep = pStep', pStep'er = pStep'er', pStep'ts = pStep'ts', pStep'src = pStep'src' - , pColour = pColour', pColour'src = pColour'src', pColour'speed = pColour'speed' + , pColour = pColour', pColour'src = pColour'src', pColour'speed = pColour'speed', pColour'colour = pColour'colour' , tPing = tPing', tPong = tPong', fBuffer = fBuffer' , sFlakes = [], sTextures = M.empty, wSize = wSize', wFullScreen = Nothing , sNextName = 0, sRenderFlake = return undefined - , sRecord = False + , sRecord = False, sRecordFlakes = False } modifyIORef sR $ \s'->s'{ sRenderFlake = flakeRenderStart sR } addTimerCallback 40 timer @@ -354,6 +354,7 @@ keyboard sR (SpecialKey KeyF11) Down _ _ = toggleFullScreen sR keyboard sR (Char 'f') Down _ _ = toggleFullScreen sR keyboard sR (Char 'R') Down _ _ = modifyIORef sR $ \s -> s{ sRecord = not (sRecord s) } +keyboard sR (Char 'S') Down _ _ = modifyIORef sR $ \s -> s{ sRecordFlakes = not (sRecordFlakes s) } keyboard _ (Char _) Down _ _ = exitSuccess keyboard _ _ _ _ _ = return () @@ -400,6 +401,8 @@ , sTextures = M.insert (flakeName f) t (sTextures s') , sNextName = sNextName s' + 1 } + when (sRecordFlakes s) $ + saveTexture t ("snowglobe-" ++ show (flakeName f) ++ ".pgm") Step sRenderFlake' -> modifyIORef sR $ \s'->s'{ sRenderFlake = sRenderFlake' } @@ -443,15 +446,13 @@ p u v = do texCoord $ TexCoord2 ((1+u)/2) ((1+v)/2) vertex $ Vertex2 u v - x :: GLdouble - y :: GLdouble - [x, y] = map realToFrac . toList . flakePosition $ f + V2 x y = flakePosition f case flakeName f `M.lookup` sTextures s of Nothing -> return () t -> do textureBinding Texture2D $= t unsafePreservingMatrix $ do - translate $ Vector3 x y 0 + translate $ Vector3 (realToFrac x :: GLdouble) (realToFrac y :: GLdouble) 0 rotate a (Vector3 0 0 1) GL.scale d d d renderPrimitive Quads $ p (-1) (-1) >> p 1 (-1) >> p 1 1 >> p (-1) 1 @@ -478,6 +479,17 @@ textureWrapMode Texture2D T $= (Repeated, ClampToEdge) textureBinding Texture2D $= Nothing return t + +saveTexture :: TextureObject -> FilePath -> IO () +saveTexture t f = withBinaryFile f WriteMode $ \h -> do + let header = "P5\n" ++ show tSize ++ " " ++ show tSize ++ "\n255\n" + n = tSize * tSize + hPutStr h header + allocaArray n $ \p -> do + textureBinding Texture2D $= Just t + glGetTexImage gl_TEXTURE_2D 0 gl_ALPHA gl_UNSIGNED_BYTE (p :: Ptr Word8) + textureBinding Texture2D $= Nothing + hPutBuf h p n newtype FramebufferObject = FramebufferObject GLuint diff --git a/Vector.hs b/Vector.hs new file mode 100644 --- /dev/null +++ b/Vector.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} + +module Vector where + +type R = Double + +data V1 = V1 !R deriving (Show, Eq, Ord) +data V2 = V2 !R !R deriving (Show, Eq, Ord) +data V3 = V3 !R !R !R deriving (Show, Eq, Ord) +data V4 = V4 !R !R !R !R deriving (Show, Eq, Ord) + +class V a where + o :: a + (^+^) :: a -> a -> a + (^-^) :: a -> a -> a + (*^) :: R -> a -> a + (^*) :: a -> R -> a + (^/) :: a -> R -> a + dot :: a -> a -> R + +(|-|) :: V a => a -> a -> R +u |-| v = let d = u ^-^ v in d `dot` d + +norm :: V a => a -> a +norm v = v ^/ sqrt (v`dot`v) + +instance V V1 where + o = V1 0 + V1 a ^+^ V1 x = V1 (a + x) + V1 a ^-^ V1 x = V1 (a - x) + k *^ V1 x = V1 (k * x) + V1 a ^* k = V1 (a * k) + V1 a ^/ k = V1 (a / k) + V1 a `dot` V1 x = a * x + +instance V V2 where + o = V2 0 0 + V2 a b ^+^ V2 x y = V2 (a + x) (b + y) + V2 a b ^-^ V2 x y = V2 (a - x) (b - y) + k *^ V2 x y = V2 (k * x) (k * y) + V2 a b ^* k = V2 (a * k) (b * k) + V2 a b ^/ k = V2 (a / k) (b / k) + V2 a b `dot` V2 x y = a * x + b * y + +instance V V3 where + o = V3 0 0 0 + V3 a b c ^+^ V3 x y z = V3 (a + x) (b + y) (c + z) + V3 a b c ^-^ V3 x y z = V3 (a - x) (b - y) (c - z) + k *^ V3 x y z = V3 (k * x) (k * y) (k * z) + V3 a b c ^* k = V3 (a * k) (b * k) (c * k) + V3 a b c ^/ k = V3 (a / k) (b / k) (c / k) + V3 a b c `dot` V3 x y z = a * x + b * y + c * z + +cross3 :: V3 -> V3 -> V3 +cross3 (V3 a1 a2 a3) (V3 b1 b2 b3) = + V3 (a2*b3-a3*b2) (a3*b1-a1*b3) (a1*b2-a2*b1) + +instance V V4 where + o = V4 0 0 0 0 + V4 a b c d ^+^ V4 x y z w = V4 (a + x) (b + y) (c + z) (d + w) + V4 a b c d ^-^ V4 x y z w = V4 (a - x) (b - y) (c - z) (d - w) + k *^ V4 x y z w = V4 (k * x) (k * y) (k * z) (k * w) + V4 a b c d ^* k = V4 (a * k) (b * k) (c * k) (d * k) + V4 a b c d ^/ k = V4 (a / k) (b / k) (c / k) (d / k) + V4 a b c d `dot` V4 x y z w = a * x + b * y + c * z + d * w + +data M1 = M1 !R deriving (Show, Eq, Ord) +data M2 = M2 !R !R !R !R deriving (Show, Eq, Ord) +data M3 = M3 !R !R !R !R !R !R !R !R !R deriving (Show, Eq, Ord) +data M4 = M4 !R !R !R !R !R !R !R !R !R !R !R !R !R !R !R !R deriving (Show, Eq, Ord) + +class M a where + i :: a + (^^+^^) :: a -> a -> a + (^^-^^) :: a -> a -> a + (^^*^^) :: a -> a -> a + (*^^) :: R -> a -> a + (^^*) :: a -> R -> a + (^^/) :: a -> R -> a + mdot :: a -> a -> R + det :: a -> R + inv :: a -> a + +(||-||) :: M a => a -> a -> R +u ||-|| v = let d = u ^^-^^ v in d `mdot` d + +instance M M1 where + i = M1 1 + M1 a11 ^^+^^ M1 b11 = M1 (a11 + b11) + M1 a11 ^^-^^ M1 b11 = M1 (a11 - b11) + M1 a11 ^^*^^ M1 b11 = M1 (a11 * b11) + a *^^ M1 b11 = M1 (a * b11) + M1 a11 ^^* b = M1 (a11 * b) + M1 a11 ^^/ b = M1 (a11 / b) + M1 a11 `mdot` M1 b11 = (a11 * b11) + det (M1 a11) = a11 + inv (M1 a11) = M1 (1/a11) + +instance M M2 where + i = M2 1 0 0 1 + M2 a11 a12 a21 a22 ^^+^^ M2 b11 b12 b21 b22 = + M2 (a11 + b11) (a12 + b12) (a21 + b21) (a22 + b22) + M2 a11 a12 a21 a22 ^^-^^ M2 b11 b12 b21 b22 = + M2 (a11 - b11) (a12 - b12) (a21 - b21) (a22 - b22) + M2 a11 a12 a21 a22 ^^*^^ M2 b11 b12 b21 b22 = + M2 (a11*b11 + a12*b21) (a11*b12 + a12*b22) (a21*b11 + a22*b21) (a21*b12 + a22*b22) + a *^^ M2 b11 b12 b21 b22 = M2 (a * b11) (a * b12) (a * b21) (a * b22) + M2 a11 a12 a21 a22 ^^* b = M2 (a11 * b) (a12 * b) (a21 * b) (a22 * b) + M2 a11 a12 a21 a22 ^^/ b = M2 (a11 / b) (a12 / b) (a21 / b) (a22 / b) + M2 a11 a12 a21 a22 `mdot` M2 b11 b12 b21 b22 = + a11*b11 + a12*b12 + a21*b21 + a22*b22 + det (M2 a11 a12 a21 a22) = a11 * a22 - a12 * a21 + inv a@(M2 a11 a12 a21 a22) = (M2 a22 (-a12) (-a21) a11) ^^/ det a + +instance M M3 where + i = M3 1 0 0 0 1 0 0 0 1 + M3 a11 a12 a13 a21 a22 a23 a31 a32 a33 ^^+^^ M3 b11 b12 b13 b21 b22 b23 b31 b32 b33 = + M3 (a11 + b11) (a12 + b12) (a13 + b13) (a21 + b21) (a22 + b22) (a23 + b23) (a31 + b31) (a32 + b32) (a33 + b33) + M3 a11 a12 a13 a21 a22 a23 a31 a32 a33 ^^-^^ M3 b11 b12 b13 b21 b22 b23 b31 b32 b33 = + M3 (a11 - b11) (a12 - b12) (a13 - b13) (a21 - b21) (a22 - b22) (a23 - b23) (a31 - b31) (a32 - b32) (a33 - b33) + M3 a11 a12 a13 a21 a22 a23 a31 a32 a33 ^^*^^ M3 b11 b12 b13 b21 b22 b23 b31 b32 b33 = + M3 (a11*b11 + a12*b21 + a13*b31) (a11*b12 + a12*b22 + a13*b32) (a11*b13 + a12*b23 + a13*b33) + (a21*b11 + a22*b21 + a23*b31) (a21*b12 + a22*b22 + a23*b32) (a21*b13 + a22*b23 + a23*b33) + (a31*b11 + a32*b21 + a33*b31) (a31*b12 + a32*b22 + a33*b32) (a31*b13 + a32*b23 + a33*b33) + a *^^ M3 b11 b12 b13 b21 b22 b23 b31 b32 b33 = + M3 (a * b11) (a * b12) (a * b13) (a * b21) (a * b22) (a * b23) (a * b31) (a * b32) (a * b33) + M3 a11 a12 a13 a21 a22 a23 a31 a32 a33 ^^* b = + M3 (a11 * b) (a12 * b) (a13 * b) (a21 * b) (a22 * b) (a23 * b) (a31 * b) (a32 * b) (a33 * b) + M3 a11 a12 a13 a21 a22 a23 a31 a32 a33 ^^/ b = + M3 (a11 / b) (a12 / b) (a13 / b) (a21 / b) (a22 / b) (a23 / b) (a31 / b) (a32 / b) (a33 / b) + M3 a11 a12 a13 a21 a22 a23 a31 a32 a33 `mdot` M3 b11 b12 b13 b21 b22 b23 b31 b32 b33 = + a11*b11 + a12*b12 + a13*b13 + + a21*b21 + a22*b22 + a23*b23 + + a31*b31 + a32*b32 + a33*b33 + det (M3 a11 a12 a13 a21 a22 a23 a31 a32 a33) = + let m11 = M2 a22 a23 a32 a33 + m12 = M2 a21 a23 a31 a33 + m13 = M2 a21 a22 a31 a32 + in a11 * det m11 - a12 * det m12 + a13 * det m13 + inv a@(M3 a11 a12 a13 a21 a22 a23 a31 a32 a33) = + let m11 = a33 * a22 - a32 * a23 + m12 = -(a33 * a12 - a32 * a13) + m13 = a23 * a12 - a22 * a13 + m21 = -(a33 * a21 - a31 * a23) + m22 = a33 * a11 - a31 * a13 + m23 = -(a23 * a11 - a21 * a13) + m31 = a32 * a21 - a31 * a22 + m32 = -(a32 * a11 - a31 * a12) + m33 = a22 * a11 - a21 * a12 + in (M3 m11 m12 m13 m21 m22 m23 m31 m32 m33) ^^/ det a + +instance M M4 where + i = M4 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 + M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44 ^^+^^ M4 b11 b12 b13 b14 b21 b22 b23 b24 b31 b32 b33 b34 b41 b42 b43 b44 = + M4 (a11 + b11) (a12 + b12) (a13 + b13) (a14 + b14) + (a21 + b21) (a22 + b22) (a23 + b23) (a24 + b24) + (a31 + b31) (a32 + b32) (a33 + b33) (a34 + b34) + (a41 + b41) (a42 + b42) (a43 + b43) (a44 + b44) + M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44 ^^-^^ M4 b11 b12 b13 b14 b21 b22 b23 b24 b31 b32 b33 b34 b41 b42 b43 b44 = + M4 (a11 - b11) (a12 - b12) (a13 - b13) (a14 - b14) + (a21 - b21) (a22 - b22) (a23 - b23) (a24 - b24) + (a31 - b31) (a32 - b32) (a33 - b33) (a34 - b34) + (a41 - b41) (a42 - b42) (a43 - b43) (a44 - b44) + M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44 ^^*^^ M4 b11 b12 b13 b14 b21 b22 b23 b24 b31 b32 b33 b34 b41 b42 b43 b44 = + M4 (a11*b11 + a12*b21 + a13*b31 + a14*b41) (a11*b12 + a12*b22 + a13*b32 + a14*b42) (a11*b13 + a12*b23 + a13*b33 + a14*b43) (a11*b14 + a12*b24 + a13*b34 + a14*b44) + (a21*b11 + a22*b21 + a23*b31 + a24*b41) (a21*b12 + a22*b22 + a23*b32 + a24*b42) (a21*b13 + a22*b23 + a23*b33 + a24*b43) (a21*b14 + a22*b24 + a23*b34 + a24*b44) + (a31*b11 + a32*b21 + a33*b31 + a34*b41) (a31*b12 + a32*b22 + a33*b32 + a34*b42) (a31*b13 + a32*b23 + a33*b33 + a34*b43) (a31*b14 + a32*b24 + a33*b34 + a34*b44) + (a41*b11 + a42*b21 + a43*b31 + a44*b41) (a41*b12 + a42*b22 + a43*b32 + a44*b42) (a41*b13 + a42*b23 + a43*b33 + a44*b43) (a41*b14 + a42*b24 + a43*b34 + a44*b44) + a *^^ M4 b11 b12 b13 b14 b21 b22 b23 b24 b31 b32 b33 b34 b41 b42 b43 b44 = + M4 (a * b11) (a * b12) (a * b13) (a * b14) + (a * b21) (a * b22) (a * b23) (a * b24) + (a * b31) (a * b32) (a * b33) (a * b34) + (a * b41) (a * b42) (a * b43) (a * b44) + M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44 ^^* b = + M4 (a11 * b) (a12 * b) (a13 * b) (a14 * b) + (a21 * b) (a22 * b) (a23 * b) (a24 * b) + (a31 * b) (a32 * b) (a33 * b) (a34 * b) + (a41 * b) (a42 * b) (a43 * b) (a44 * b) + M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44 ^^/ b = + M4 (a11 / b) (a12 / b) (a13 / b) (a14 / b) + (a21 / b) (a22 / b) (a23 / b) (a24 / b) + (a31 / b) (a32 / b) (a33 / b) (a34 / b) + (a41 / b) (a42 / b) (a43 / b) (a44 / b) + M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44 `mdot` M4 b11 b12 b13 b14 b21 b22 b23 b24 b31 b32 b33 b34 b41 b42 b43 b44 = + a11*b11 + a12*b12 + a13*b13 + a14*b14 + + a21*b21 + a22*b22 + a23*b23 + a24*b24 + + a31*b31 + a32*b32 + a33*b33 + a34*b34 + + a41*b41 + a42*b42 + a43*b43 + a44*b44 + det (M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44) = + let m11 = M3 a22 a23 a24 a32 a33 a34 a42 a43 a44 + m12 = M3 a21 a23 a24 a31 a33 a34 a41 a43 a44 + m13 = M3 a21 a22 a24 a31 a32 a34 a41 a42 a44 + m14 = M3 a21 a22 a23 a31 a32 a33 a41 a42 a43 + in a11 * det m11 - a12 * det m12 + a13 * det m13 - a14 * det m14 + inv (M4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 a41 a42 a43 a44) = + let a = M2 a11 a12 a21 a22 + b = M2 a13 a14 a23 a24 + c = M2 a31 a32 a41 a42 + d = M2 a33 a34 a43 a44 + a1 = inv a + ca1 = c ^^*^^ a1 + dcab1 = inv (d ^^-^^ (ca1 ^^*^^ b)) + a1bdcab1 = a1 ^^*^^ (b ^^*^^ dcab1) + M2 m11 m12 m21 m22 = a1 ^^+^^ (a1bdcab1 ^^*^^ ca1) + M2 m13 m14 m23 m24 = (-1) *^^ a1bdcab1 + M2 m31 m32 m41 m42 = (-1) *^^ (dcab1 ^^*^^ ca1) + M2 m33 m34 m43 m44 = dcab1 + in M4 m11 m12 m13 m14 m21 m22 m23 m24 m31 m32 m33 m34 m41 m42 m43 m44 + +class MV m v where + (^^*^) :: m -> v -> v + (^*^!) :: v -> v -> m + +reflector :: (M m, V v, MV m v) => v -> m +reflector v = i ^^-^^ (2 *^^ (v ^*^! v)) + +instance MV M1 V1 where + M1 m ^^*^ V1 v = V1 (m * v) + V1 a ^*^! V1 b = M1 (a * b) + +instance MV M2 V2 where + M2 m11 m12 m21 m22 ^^*^ V2 v1 v2 = + V2 (m11*v1 + m12*v2) + (m21*v1 + m22*v2) + V2 a1 a2 ^*^! V2 b1 b2 = + M2 (a1 * b1) (a1 * b2) + (a2 * b1) (a2 * b2) + +instance MV M3 V3 where + M3 m11 m12 m13 m21 m22 m23 m31 m32 m33 ^^*^ V3 v1 v2 v3 = + V3 (m11*v1 + m12*v2 + m13*v3) + (m21*v1 + m22*v2 + m23*v3) + (m31*v1 + m32*v2 + m33*v3) + V3 a1 a2 a3 ^*^! V3 b1 b2 b3 = + M3 (a1 * b1) (a1 * b2) (a1 * b3) + (a2 * b1) (a2 * b2) (a2 * b3) + (a3 * b1) (a3 * b2) (a3 * b3) + +instance MV M4 V4 where + M4 m11 m12 m13 m14 m21 m22 m23 m24 m31 m32 m33 m34 m41 m42 m43 m44 ^^*^ V4 v1 v2 v3 v4 = + V4 (m11*v1 + m12*v2 + m13*v3 + m14*v4) + (m21*v1 + m22*v2 + m23*v3 + m24*v4) + (m31*v1 + m32*v2 + m33*v3 + m34*v4) + (m41*v1 + m42*v2 + m43*v3 + m44*v4) + V4 a1 a2 a3 a4 ^*^! V4 b1 b2 b3 b4 = + M4 (a1 * b1) (a1 * b2) (a1 * b3) (a1 * b4) + (a2 * b1) (a2 * b2) (a2 * b3) (a2 * b4) + (a3 * b1) (a3 * b2) (a3 * b3) (a3 * b4) + (a4 * b1) (a4 * b2) (a4 * b3) (a4 * b4) + +cross4 :: V4 -> V4 -> V4 -> V4 +cross4 (V4 u0 u1 u2 u3) (V4 v0 v1 v2 v3) (V4 w0 w1 w2 w3) = +{- + let vw01 = v0 * w1 - v1 * w0 + vw02 = v0 * w2 - v2 * w0 + vw03 = v0 * w3 - v3 * w0 + vw12 = v1 * w2 - v2 * w1 + vw13 = v1 * w3 - v3 * w1 + vw23 = v2 * w3 - v3 * w2 + r0 = u1 * vw23 - u2 * vw13 + u3 * vw12 + r1 = - u0 * vw23 + u2 * vw03 - u3 * vw02 + r2 = u0 * vw13 - u1 * vw03 + u3 * vw02 + r3 = - u0 * vw12 + u1 * vw02 - u2 * vw01 + in V4 r0 r1 r2 r3 +-} + let m0 = M3 u1 u2 u3 v1 v2 v3 w1 w2 w3 + m1 = M3 u0 u2 u3 v0 v2 v3 w0 w2 w3 + m2 = M3 u0 u1 u3 v0 v1 v3 w0 w1 w3 + m3 = M3 u0 u1 u2 v0 v1 v2 w0 w1 w2 + in V4 (det m0) (-(det m1)) (det m2) (-(det m3)) diff --git a/snowglobe.cabal b/snowglobe.cabal --- a/snowglobe.cabal +++ b/snowglobe.cabal @@ -1,5 +1,5 @@ Name: snowglobe -Version: 2.0.0.2 +Version: 3 Synopsis: randomized fractal snowflakes demo Description: @snowglobe@ generates random snowflakes using iterated function systems via OpenGL texture feedback. The @@ -11,6 +11,9 @@ . * shift-R: toggle recording PPM images to stdout . + * shift-S: toggle recording PGM images of each + generated flake to the current working directory + . * any other key: quit License: GPL-3 @@ -23,6 +26,7 @@ Executable snowglobe Main-is: SnowGlobe.hs + other-modules: Vector GHC-options: -Wall Build-depends: base < 5, @@ -30,7 +34,6 @@ containers, gl-capture, GLUT, - hmatrix, OpenGL == 2.9.*, OpenGLRaw, random @@ -42,4 +45,4 @@ Source-repository this type: git location: git://gitorious.org/maximus/snowglobe.git - tag: v2.0.0.2 + tag: v3