0 | {- Tian Z (ecburx@burx.vip) -}
  1 |
  2 | module IdrisGL.Simulate
  3 |
  4 | import Control.Monad.State
  5 |
  6 | import IdrisGL.Picture
  7 | import IdrisGL.DataType
  8 | import IdrisGL.Color
  9 | import IdrisGL.SDL.SDL_event
 10 | import IdrisGL.SDL.SDL_video
 11 | import IdrisGL.SDL.SDL_render
 12 | import IdrisGL.SDL.SDL_surface
 13 | import IdrisGL.SDL.SDL_timer
 14 |
 15 | ||| Run a simulation in a window.
 16 | |||
 17 | ||| @ window  Display mode.
 18 | ||| @ bgColor Background color.
 19 | ||| @ tpf     Time per frame. Providing frames per seconds control. (FPS) = 1/<value> (0: unlimited FPS)
 20 | ||| @ model   The initial model.
 21 | ||| @ m2p     Function to step the model one iteration.
 22 | ||| @ m2m     A function to step the model one iteration. It passes the amount of time (seconds) since the window creation.
 23 | export
 24 | simulate 
 25 |   :  (window  : Display)
 26 |   -> (bgColor : Color)
 27 |   -> (tpf     : Double)
 28 |   -> (model   : a)
 29 |   -> (m2p     : (a -> Picture))
 30 |   -> (m2m     : (Double -> a -> a))
 31 |   -> IO ()
 32 |
 33 | simulate window bgColor tps m m2p m2m = do
 34 |     win                   <- createWin window
 35 |     ren                   <- createRenderer win
 36 |     e                     <- newEve
 37 |     loop                     ren win e m 0
 38 |     closeWin                 win
 39 |     freeEve                  e
 40 |     freeRender               ren
 41 | where 
 42 |   mutual
 43 |       loop : Renderer -> Win -> Event -> a -> Double -> IO ()
 44 |       loop ren win e model lastTime = 
 45 |         if   !getSecondsTicks - lastTime < tps
 46 |         then loop'           ren win e model lastTime
 47 |         else do
 48 |           setRenderDrawColor ren bgColor
 49 |           renderClear        ren
 50 |           loadPicture        (m2p model) ren win
 51 |           renderPresent      ren
 52 |           currT           <- getSecondsTicks
 53 |           let newM        =  m2m currT model
 54 |           loop' ren win e newM currT
 55 |
 56 |       loop' : Renderer -> Win -> Event -> a -> Double -> IO ()
 57 |       loop'   ren win e m lastTime with (eveType e)
 58 |         loop' _   _   _ _ _        | E_QUIT = pure ()
 59 |         loop' ren win e m lastTime | _      = loop ren win e m lastTime
 60 |
 61 | ||| Run a simulation with mutable state in a window.
 62 | |||
 63 | ||| @ window  Display mode.
 64 | ||| @ bgColor Background color.
 65 | ||| @ tpf     Time per frame. Providing frames per seconds control. (FPS) = 1/<value> (0: unlimited FPS)
 66 | ||| @ model   The initial model.
 67 | ||| @ m2p     Describes how to produce pictures to show.
 68 | ||| @ m2m     A stateful function to step the model one iteration. It passes the amount of time (seconds) since the window creation.
 69 | export
 70 | simulateStateT
 71 |   :  (window    : Display)
 72 |   -> (bgColor   : Color)
 73 |   -> (tpf       : Double)
 74 |   -> (stateType : a)
 75 |   -> (m2p       : StateT a IO Picture)
 76 |   -> (m2m       : Double -> StateT a IO ())
 77 |   -> IO ()
 78 |
 79 | simulateStateT window bgColor tps state m2p m2m = do
 80 |     win                   <- createWin window
 81 |     ren                   <- createRenderer win
 82 |     e                     <- newEve
 83 |     loop                     state ren win e 0
 84 |     closeWin                 win
 85 |     freeEve                  e
 86 |     freeRender               ren
 87 | where
 88 |   mutual
 89 |       loop : a -> Renderer -> Win -> Event -> Double -> IO ()
 90 |       loop st ren win e lastTime = 
 91 |         if   !getSecondsTicks - lastTime < tps
 92 |         then loop'           st ren win e lastTime
 93 |         else do
 94 |           setRenderDrawColor ren bgColor
 95 |           renderClear        ren
 96 |           (st, pics)      <- runStateT st m2p
 97 |           loadPicture        pics ren win
 98 |           renderPresent      ren
 99 |           currT           <- getSecondsTicks
100 |           st              <- execStateT st (m2m currT)
101 |           loop'              st ren win e currT
102 |
103 |       loop' : a -> Renderer -> Win -> Event -> Double -> IO ()
104 |       loop'   st ren win e lastTime with (eveType e)
105 |         loop' _  _   _   _ _        | E_QUIT = pure ()
106 |         loop' st ren win e lastTime | _      = loop st ren win e lastTime
107 |