rsagl 0.2.1 → 0.2.2
raw patch · 3 files changed
+5/−308 lines, 3 filesnew-uploader
Files
- Models/PlanetRingMoon.hs +0/−131
- RSAGL/Main.hs +0/−171
- rsagl.cabal +5/−6
− Models/PlanetRingMoon.hs
@@ -1,131 +0,0 @@-module Models.PlanetRingMoon- (planet,ring,moon,ground,monolith,station,orb,glow_orb,orb_upper_leg,orb_lower_leg)- where--import RSAGL.Model-import RSAGL.Vector-import RSAGL.ModelingExtras-import RSAGL.RayTrace-import RSAGL.Affine-import RSAGL.Auxiliary-import System.Random-import RSAGL.Angle-import RSAGL.CurveExtras-import RSAGL.Curve--ring :: Modeling ()-ring = model $ do openDisc 0.75 1.0- material $- do transparent $ pure $ alpha 0.25 purple- specular 2 $ pure purple- bumps $ waves 0.2 0.01- twoSided True--planet :: Modeling ()-planet = model $ - do sphere (Point3D 0 0 0) 0.65- deform $ constrain (\(SurfaceVertex3D (Point3D x y z) _) -> x > 0 && y > 0 && z > 0) $ - shadowDeform (Vector3D (-1) (-1) (-1)) (map (plane (Point3D 0 0 0)) [Vector3D 1 0 0,Vector3D 0 1 0,Vector3D 0 0 1])- let land_vs_water land water = pattern (cloudy 26 0.4) [(0,water),(0.5,water),(0.51,land),(1,land)]- let grass_and_mountains = pattern (cloudy 81 0.25) [(0.4,pattern (cloudy 99 0.1) [(0.0,pure brown),(1.0,pure slate_gray)]),(0.5,pure forest_green)]- let land_and_water = land_vs_water grass_and_mountains (pure blue)- let cities bright dark = land_vs_water (pattern (cloudy 5 0.1) [(0.0,bright),(0.5,dark)]) (dark)- let planet_surface = pattern (gradient (Point3D 0 0 0) (Vector3D 0 0.65 0)) - [(-0.9,pure white),(-0.85,land_and_water),(0.85,land_and_water),(0.9,pure white)]- let planet_interior inner_core outer_core crust = pattern (spherical (Point3D 0 0 0) 0.65) - [(0.0,inner_core),(0.25,inner_core),(0.5,outer_core),(0.95,outer_core),(1.0,crust)]- material $- do pigment $ planet_interior (pure blackbody) (pure blackbody) $ cities (pure black) planet_surface- emissive $ planet_interior (pure yellow) (pure red) $ cities (pure $ scaleRGB 0.2 white) (pure blackbody)- specular 20 $ planet_interior (pure blackbody) (pure blackbody) $ land_vs_water (pure blackbody) (pure white)--moon :: Modeling ()-moon = model $ - do sphere (Point3D 0 0 0) 0.2- material $ pigment $ pattern (cloudy 8 0.05) [(0.0,pure slate_gray),(1.0,pure black)]--monolith :: Modeling ()-monolith = model $- do smoothbox 0.1 (Point3D 4 9 1) (Point3D (-4) (-9) (-1))- affine (translate $ Vector3D 0 9 0)- affine (scale' 0.20)- material $- do pigment $ pure blackbody- specular 100 $ pure white--ground :: Modeling ()-ground = model $- do closedDisc (Point3D 0 (-0.1) 0) (Vector3D 0 1 0) 75- material $ pigment $ pattern (cloudy 27 1.0) [(0.0,pure brown),(1.0,pure forest_green)]--station :: Modeling ()-station = model $- do model $ - do torus 0.5 0.1- openCone (Point3D (-0.5) 0 0,0.02) (Point3D 0.5 0 0,0.02)- openCone (Point3D 0 0 (-0.5),0.02) (Point3D 0 0 0.5,0.02)- closedCone (Point3D 0 0.2 0,0.2) (Point3D 0 (-0.2) 0,0.2)- material $ - do pigment $ pure silver- specular 100 $ pure silver- model $ - do box (Point3D (-0.15) 0.19 (-0.05)) (Point3D 0.15 0.21 0.05)- material $ emissive $ pure white- sequence_ $ dropRandomElements 30 (mkStdGen 19) $ concatMap (rotationGroup (Vector3D 0 1 0) 40) $ - [window_box,- transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees 25) window_box,- transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees (-25)) window_box,- transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees 50) window_box,- transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees (-50)) window_box]- where window_box = model $- do quadralateral (Point3D 0.51 (-0.105) 0.03) (Point3D 0.49 (-0.105) 0.03)- (Point3D 0.49 (-0.105) (-0.03)) (Point3D 0.51 (-0.105) (-0.03))- quadralateral (Point3D 0.51 0.105 (-0.03)) (Point3D 0.49 0.105 (-0.03))- (Point3D 0.49 0.105 0.03) (Point3D 0.51 0.105 0.03)- material $- do pigment $ pure black- emissive $ pure white- tesselationHintComplexity 0- fixed (3,3)--orb :: Modeling ()-orb = model $- do sor $ linearInterpolation $ points2d- [(-0.001,0.4),- (0.5,0.45),- (0.5,0.4),- (0.6,0.4),- (0.6,0.6),- (0.5,0.6),- (0.5,0.55),- (-0.001,0.6)]- sequence_ $ rotationGroup (Vector3D 0 1 0) 5 $- tube $ zipCurve (,) (pure 0.05) $ smoothCurve 3 0.4 $ loopedLinearInterpolation $ points3d- [(0.4,0.2,0.4),- (0.4,0.8,0.8),- (-0.4,0.8,0.8),- (-0.4,0.2,0.4)]- regularPrism (Point3D 0 0.5 0,0.5) (Point3D 0 1.0 0,-0.001) 4- material $- do pigment $ pure gold- specular 64 $ pure silver--glow_orb :: Modeling ()-glow_orb = translate (Vector3D 0 1 0) $- do closedDisc (Point3D 0 0 0) (Vector3D 0 1 0) 1- material $ emissive $ pattern (spherical (Point3D 0 0 0) 1) [(0.0,pure $ scaleRGB 1.5 white),(0.25,pure white),(0.95,pure blackbody)]--orb_upper_leg :: Modeling ()-orb_upper_leg =- do tube $ zipCurve (,) (pure 0.05) $ linearInterpolation [Point3D 0 0 0,Point3D 0 0.1 0.5,Point3D 0 0 1]- sphere (Point3D 0 0 1) 0.05- material $- do pigment $ pure gold- specular 64 $ pure silver--orb_lower_leg :: Modeling ()-orb_lower_leg =- do openCone (Point3D 0 0 0,0.05) (Point3D 0 0 1,-0.001)- material $ - do pigment $ pure gold- specular 64 $ pure silver
− RSAGL/Main.hs
@@ -1,171 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports -farrows #-}--module RSAGL.Main- (main,- displayModel)- where--import Data.IORef-import System.IO-import Graphics.UI.GLUT as GLUT-import Graphics.Rendering.OpenGL.GLU.Errors-import RSAGL.Model-import Models.PlanetRingMoon-import RSAGL.Time-import Control.Monad-import Control.Monad.Trans-import RSAGL.Angle-import System.Exit-import RSAGL.Color-import RSAGL.Bottleneck-import RSAGL.QualityControl-import RSAGL.Scene-import RSAGL.FRP-import RSAGL.Animation-import RSAGL.AnimationExtras-import RSAGL.ThreadedArrow-import Control.Arrow-import RSAGL.Vector-import RSAGL.RSAGLColors-import RSAGL.CoordinateSystems-import qualified RSAGL.Affine as Affine-import RSAGL.Matrix-import RSAGL.Interpolation-import Debug.Trace-import RSAGL.ModelingExtras-import RSAGL.WrappedAffine-import RSAGL.InverseKinematics--test_quality :: Integer-test_quality = 2^14---test_quality = 64--moon_orbital_animation :: AniA () i o (IO IntermediateModel) (CSN Point3D)-moon_orbital_animation =- accelerationModel (perSecond 60)- (Point3D (-6) 0 0,perSecond $ Vector3D 0.0 0.14 0.18)- (arr $ const $ inverseSquareLaw 1.0 origin_point_3d)- (proc (_,im) -> do rotateA (Vector3D 0 1 0) (perSecond $ fromDegrees 20) accumulateSceneA -< (Infinite,sceneObject im)- exportA -< origin_point_3d)--walking_orb_animation :: QualityCache Integer IntermediateModel -> QualityCache Integer IntermediateModel ->- QualityCache Integer IntermediateModel -> QualityCache Integer IntermediateModel ->- IO (AniA () i o () ())-walking_orb_animation qo_orb qo_glow_orb qo_orb_upper_leg qo_orb_lower_leg =- do let upper_leg_anim = proc () -> accumulateSceneA -< (Local,sceneObject $ getQuality qo_orb_upper_leg 50)- let lower_leg_anim = proc () -> accumulateSceneA -< (Local,sceneObject $ getQuality qo_orb_lower_leg 50)- let orb_legs = legs $ rotationGroup (Vector3D 0 1 0) 7 $- leg (Vector3D 0 1 1) (Point3D 0 0.5 0.5) 2 (Point3D 0 0 1.8) $ jointAnimation upper_leg_anim lower_leg_anim- return $ proc () ->- do accumulateSceneA -< (Local,sceneObject $ getQuality qo_orb test_quality)- transformA pointAtCameraA -< (Affine $ Affine.translate (Vector3D 0 1.05 0),(Local,getQuality qo_glow_orb test_quality))- accumulateSceneA -< (Local,lightSource $ PointLight (Point3D 0 0 0)- (measure (Point3D 0 0 0) (Point3D 0 6 0))- (scaleRGB 0.5 white) blackbody)- orb_legs -< ()- returnA -< ()--testScene :: IO (AniM ((),Camera))-testScene = - do bottleneck <- newBottleneck- let newQO im = newQuality bottleneck parIntermediateModel (flip toIntermediateModel im) $ iterate (*2) 64- putStrLn "loading planet..."- qo_planet <- newQO planet- putStrLn "loading ring..."- qo_ring <- newQO ring- putStrLn "loading moon..."- qo_moon <- newQO moon- putStrLn "loading ground..."- qo_ground <- newQO ground- putStrLn "loading monolith..."- qo_monolith <- newQO monolith- putStrLn "loading station..."- qo_station <- newQO station- putStrLn "loading orb..."- qo_orb <- newQO orb- putStrLn "loading glow_orb..."- qo_glow_orb <- newQO glow_orb- putStrLn "loading orb_upper_leg..."- qo_orb_upper_leg <- newQO orb_upper_leg- putStrLn "loading orb_lower_leg..."- qo_orb_lower_leg <- newQO orb_lower_leg- putStrLn "done."- walking_orb_animation_arrow <- walking_orb_animation qo_orb qo_glow_orb qo_orb_upper_leg qo_orb_lower_leg- ao_walking_orb <- newAnimationObjectA (arr (map snd) <<< frpContext nullaryThreadIdentity [((),walking_orb_animation_arrow)])- ao_moon_orbit <- newAnimationObjectA (arr (map snd) <<< frpContext nullaryThreadIdentity [((),moon_orbital_animation)])- return $ - do rotation_planet <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 25)- rotation_station <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 5)- rotation_camera <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 3)- rotation_orb <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 7)- accumulateSceneM Local $ sceneObject $ getQuality qo_ground test_quality- accumulateSceneM Local $ sceneObject $ getQuality qo_monolith test_quality- transformM (affineOf $ Affine.translate (Vector3D 0 1 (-4)) . Affine.rotate (Vector3D 1 0 0) (fromDegrees 90) . rotation_station) $ - accumulateSceneM Infinite $ sceneObject $ getQuality qo_station test_quality- transformM (affineOf $ rotation_orb . Affine.translate (Vector3D (4) 0 0)) $- do runAnimationObject ao_walking_orb ()- transformM (affineOf $ Affine.translate (Vector3D 0 1 6)) $ - do transformM (affineOf rotation_planet) $ accumulateSceneM Infinite $ sceneObject $ getQuality qo_planet test_quality- accumulateSceneM Infinite $ lightSource $ DirectionalLight (vectorNormalize $ Vector3D 1 (-1) (-1)) white blackbody- accumulateSceneM Infinite $ lightSource $ DirectionalLight (vectorNormalize $ Vector3D (-1) 1 1) (scaleRGB 0.5 red) blackbody- accumulateSceneM Infinite $ sceneObject $ getQuality qo_ring test_quality- runAnimationObject ao_moon_orbit $ getQuality qo_moon test_quality- return ((),PerspectiveCamera (transformation rotation_camera $ Point3D 1 2 (-8))- (Point3D 0 2.5 2)- (Vector3D 0 1 0)- (fromDegrees 45))--main :: IO ()-main = displayModel--default_window_size :: Size-default_window_size = Size 800 600--display_mode :: [DisplayMode]-display_mode = [RGBAMode,- WithDepthBuffer,- DoubleBuffered]--timer_callback_millis :: Int-timer_callback_millis = 5--displayModel :: IO ()-displayModel =- do _ <- getArgsAndInitialize- initialWindowSize $= default_window_size- initialDisplayMode $= display_mode- window <- createWindow "RSAGL Test Mode"- reshapeCallback $= Just rsaglReshapeCallback- counter <- newIORef 0- testSceneCallback <- testScene- displayCallback $= rsaglDisplayCallback counter (testSceneCallback)- idleCallback $= (Just $ return ())- addTimerCallback timer_callback_millis (rsaglTimerCallback window)- mainLoop--rsaglReshapeCallback :: Size -> IO ()-rsaglReshapeCallback (Size width height) = do matrixMode $= Projection- loadIdentity- viewport $= (Position 0 0,Size width height)- matrixMode $= Modelview 0--rsaglDisplayCallback :: (IORef Integer) -> AniM ((),Camera) -> IO ()-rsaglDisplayCallback counter aniM =- do loadIdentity- color (Color4 0.0 0.0 0.0 0.0 :: Color4 Double)- clear [ColorBuffer]- the_scene <- liftM snd $ runAniM aniM- (Size w h) <- GLUT.get windowSize- sceneToOpenGL (fromIntegral w / fromIntegral h) (0.1,30) the_scene- swapBuffers- modifyIORef counter (+1)- errs <- (get errors)- when (not $ null errs) $ print $ show errs- frames <- readIORef counter- when (frames `mod` 200 == 0) $ putStrLn $ "frames: " ++ show frames- when (frames >= 4000) $ exitWith ExitSuccess--rsaglTimerCallback :: Window -> IO ()-rsaglTimerCallback window = - do addTimerCallback timer_callback_millis (rsaglTimerCallback window)- postRedisplay $ Just window
rsagl.cabal view
@@ -1,8 +1,8 @@ name: rsagl-version: 0.2.1+version: 0.2.2 license: BSD3 license-file: LICENSE-author: Christopher Lane Hinson+author: Christopher Lane Hinson <lane@downstairspeople.org> maintainer: Christopher Lane Hinson <lane@downstairspeople.org> category: Game, Graphics@@ -14,18 +14,17 @@ roguestar, but every effort has been made (including the license) to make it accessable to other projects that might benefit from it. .- The Darcs repository is available at <http://www.downstairspeople.org/darcs/rsagl>.+ The git repository is available at <http://www.downstairspeople.org/git/rsagl.git>. homepage: http://roguestar.downstairspeople.org/ build-depends: base>3, old-time, random, array, arrows, containers, parallel, mtl, OpenGL, GLUT, QuickCheck<2 build-type: Simple tested-with: GHC==6.8.2 -exposed-modules: Models.PlanetRingMoon,- RSAGL.FRPBase, RSAGL.RayTrace, RSAGL.StatefulArrow,+exposed-modules: RSAGL.FRPBase, RSAGL.RayTrace, RSAGL.StatefulArrow, RSAGL.Material, RSAGL.Auxiliary, RSAGL.BoundingBox, RSAGL.Vector, RSAGL.KinematicSensors, RSAGL.RSAGLColors,- RSAGL.Extrusion, RSAGL.Main, RSAGL.Color,+ RSAGL.Extrusion, RSAGL.Color, RSAGL.SwitchedArrow, RSAGL.Time, RSAGL.Matrix, RSAGL.Joint, RSAGL.ArrowTransformerOptimizer, RSAGL.ProcessColors, RSAGL.Affine, RSAGL.WrappedAffine, RSAGL.CurveExtras,