new examples

This commit is contained in:
nek0 2017-12-28 16:56:49 +01:00
parent 59b60f58c3
commit 8a5370c857
3 changed files with 421 additions and 0 deletions

145
examples/example00/Main.hs Normal file
View File

@ -0,0 +1,145 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
import Affection
import qualified SDL
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
newtype StateData = StateData
{ sdSubs :: Subsystems
}
data Subsystems = Subsystems
{ subWindow :: Window
, subMouse :: Mouse
, subKeyboard :: Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
generalSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> (msg -> Affection StateData())
-> Affection StateData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
instance Participant Window StateData where
type Mesg Window StateData = WindowMessage
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Window StateData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse StateData where
type Mesg Mouse StateData = MouseMessage
partSubscribers (Mouse t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Mouse t) = generalSubscribe t
partUnSubscribe (Mouse t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard StateData where
type Mesg Keyboard StateData = KeyboardMessage
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents
main :: IO ()
main = do
logIO Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf
load :: IO StateData
load = do
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
return $ StateData $ Subsystems
(Window empty1)
(Mouse empty2)
(Keyboard empty3)
pre :: Affection StateData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
return ()
exitOnQ :: KeyboardMessage -> Affection StateData ()
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeQ -> do
liftIO $ logIO Debug "Yo dog I heard..."
quit
_ -> return ()
exitOnWindowClose :: WindowMessage -> Affection StateData ()
exitOnWindowClose wm =
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO Debug "I heard another one..."
quit
_ -> return ()
handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
(Subsystems a b c) <- sdSubs <$> getAffection
_ <- consumeSDLEvents a es
_ <- consumeSDLEvents b es
_ <- consumeSDLEvents c es
return ()
update _ = return ()
draw = return ()
clean _ = return ()

201
examples/example01/Main.hs Normal file
View File

@ -0,0 +1,201 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ForeignFunctionInterface #-}
import Affection as A
import qualified SDL
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)
import Data.Matrix as M
import qualified Data.Set as S
import System.Random (randomRIO)
import NanoVG
import Foreign.C.Types (CInt(..))
-- internal imports
import Types
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
main :: IO ()
main = do
logIO A.Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
, SDL.windowInitialSize = SDL.V2 600 600
}
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf
load :: IO UserData
load = do
-- emptyMatrix <- zero 60 60
liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit
liftIO $ logIO A.Debug "making random"
randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
liftIO $ logIO A.Debug "creating context"
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
return $ UserData
{ subsystems = Subsystems
(Window empty1)
(Keyboard empty3)
, lifeMat = fullMatrix
, nano = nanoCtx
}
pre :: Affection UserData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
_ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
_ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose
return ()
exitOnEsc :: KeyboardMessage -> Affection UserData ()
exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Yo dog I heard..."
quit
_ -> return ()
reloadOnR :: KeyboardMessage -> Affection UserData ()
reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeR -> do
ud <- getAffection
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList
nState <- liftIO $ load
putAffection ud
{ lifeMat = fullMatrix
}
_ -> return ()
exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose wm =
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..."
quit
_ -> return ()
handle :: [SDL.EventPayload] -> Affection UserData ()
handle es = do
(Subsystems a b) <- subsystems <$> getAffection
_ <- consumeSDLEvents a =<< consumeSDLEvents b es
return ()
update :: Double -> Affection UserData ()
update _ = do
ud <- getAffection
-- when (lastUpdate ud < floor now) $ do
liftIO $ logIO A.Debug "stepping life"
newList <- mapM (\coord -> do
let x = (coord `div` 60) + 1
y = (coord `mod` 60) + 1
subm
| x == 1 && y == 1 =
(submatrix 60 60 60 60 (lifeMat ud) <-> submatrix 1 2 60 60 (lifeMat ud))
<|>
(submatrix 60 60 1 2 (lifeMat ud) <-> submatrix 1 2 1 2 (lifeMat ud))
| x == 1 && y == 60 =
(submatrix 60 60 59 60 (lifeMat ud) <-> submatrix 1 2 59 60 (lifeMat ud))
<|>
(submatrix 60 60 1 1 (lifeMat ud) <-> submatrix 1 2 1 1 (lifeMat ud))
| x == 60 && y == 1 =
(submatrix 59 60 60 60 (lifeMat ud) <-> submatrix 1 1 60 60 (lifeMat ud))
<|>
(submatrix 59 60 1 2 (lifeMat ud) <-> submatrix 1 1 1 2 (lifeMat ud))
| x == 60 && y == 60 =
(submatrix 59 60 59 60 (lifeMat ud) <-> submatrix 1 1 59 60 (lifeMat ud))
<|>
(submatrix 59 60 1 1 (lifeMat ud) <-> submatrix 1 1 1 1 (lifeMat ud))
| x == 1 =
(submatrix 60 60 (y - 1) (y + 1) (lifeMat ud))
<->
(submatrix 1 2 (y - 1) (y + 1) (lifeMat ud))
| y == 1 =
(submatrix (x - 1) (x + 1) 60 60 (lifeMat ud))
<|>
(submatrix (x - 1) (x + 1) 1 2 (lifeMat ud))
| x == 60 =
(submatrix 1 1 (y - 1) (y + 1) (lifeMat ud))
<->
(submatrix 59 60 (y - 1) (y + 1) (lifeMat ud))
| y == 60 =
(submatrix (x - 1) (x + 1) 1 1 (lifeMat ud))
<|>
(submatrix (x -1 ) (x + 1) 59 60 (lifeMat ud))
| otherwise =
submatrix (x - 1) (x + 1) (y - 1) (y + 1) (lifeMat ud)
life = countLife subm
if (lifeMat ud) M.! (x, y) == 1
then if life == 2 || life == 3
then return 1
else return 0
else if life == 3
then return 1
else return 0
) [0..3599]
let newM = fromList 60 60 newList
putAffection ud
{ lifeMat = newM
}
countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2))
where
res = foldr (\a acc -> a + acc) 0 mat
draw :: Affection UserData ()
draw = do
ud <- getAffection
liftIO $ do
beginFrame (nano ud) 600 600 1
save (nano ud)
mapM_ (\coord -> do
let x = coord `div` 60
y = coord `mod` 60
ctx = nano ud
mult = lifeMat ud M.! (x + 1, y + 1)
-- logIO A.Debug $ show mult
beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
if (mult == 1)
then do
fillColor ctx (rgba 255 255 255 255)
else do
fillColor ctx (rgba 0 0 0 255)
fill ctx
) [0..3599]
restore (nano ud)
endFrame (nano ud)
clean _ = return ()

View File

@ -0,0 +1,75 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where
import Affection
import Data.Matrix as M
import NanoVG
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data UserData = UserData
{ lifeMat :: Matrix Word
, subsystems :: Subsystems
, nano :: Context
}
data Subsystems = Subsystems
{ subWindow :: Window
, subKeyboard :: Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Window UserData where
type Mesg Window UserData = WindowMessage
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Window UserData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard UserData where
type Mesg Keyboard UserData = KeyboardMessage
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> (msg -> Affection UserData ())
-> Affection UserData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p