pine (empty) → 0.1.0.0

raw patch · 12 files changed

+358/−0 lines, 12 filesdep +basedep +containersdep +pinesetup-changed

Dependencies added: base, containers, pine, sdl2, sdl2-image, stm, text

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +12/−0
• Setup.hs +2/−0
• app/Main.hs +6/−0
• pine.cabal +77/−0
• src/Pine.hs +17/−0
• src/Pine/Internal.hs +8/−0
• src/Pine/Internal/Keyboard.hs +23/−0
• src/Pine/Internal/Renderer.hs +139/−0
• src/Pine/Internal/Types.hs +39/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for pine++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright (c) 2019, grinshpon++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of grinshpon nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,12 @@+# pine++![logo](https://github.com/Grinshpon/pine/blob/master/src/Media/logo.png)+Functional Reactive Game Framework in Haskell++Inspired by [CodeWorld](https://github.com/google/codeworld) and [Elm](https://elm-lang.org/)++<br>++<br>++Currently a Work In Progress, but technically functional. Documentation is currently nonexistant and that is something I'm working on, as well as everything else

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,6 @@+module Main where++import Pine++main :: IO ()+main = runDefault

@@ -0,0 +1,77 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4fc1ee58c90bfb12e309df8f5c093661bf359f96c9c103bd0083d938471e8434++name:           pine+version:        0.1.0.0+synopsis:       Functional Reactive 2D Game Framework+description:    Please see the README on GitHub at <https://github.com/githubuser/pine#readme>+category:       Game+homepage:       https://github.com/grinshpon/pine#readme+bug-reports:    https://github.com/grinshpon/pine/issues+author:         Daniel Grinshpon+maintainer:     GrinshponDaniel@protonmail.com+copyright:      2019 Daniel Grinshpon+license:        Zlib+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/grinshpon/pine++library+  exposed-modules:+      Pine+      Pine.Internal+      Pine.Internal.Keyboard+      Pine.Internal.Renderer+      Pine.Internal.Types+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , containers >=0.6 && <0.7+    , sdl2 >=2.4 && <2.5+    , sdl2-image >=0.1 && <2.1+    , stm >=2.4 && <2.6+    , text >=1.2.3 && <1.3+  default-language: Haskell2010++executable pine-exe+  main-is: Main.hs+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers >=0.6 && <0.7+    , pine+    , sdl2 >=2.4 && <2.5+    , sdl2-image >=0.1 && <2.1+    , stm >=2.4 && <2.6+    , text >=1.2.3 && <1.3+  default-language: Haskell2010++test-suite pine-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers >=0.6 && <0.7+    , pine+    , sdl2 >=2.4 && <2.5+    , sdl2-image >=0.1 && <2.1+    , stm >=2.4 && <2.6+    , text >=1.2.3 && <1.3+  default-language: Haskell2010

@@ -0,0 +1,17 @@++module Pine+  ( runDefault+  , pine+  , Drawable(..)+  , Stateful(..)+  , Image(..)+  , newImage+  , Canvas+  , fromImage+  , Event(..)+  ) where++import Pine.Internal++runDefault :: IO ()+runDefault = defaultApp

@@ -0,0 +1,8 @@+module Pine.Internal+  ( Pine.Internal.Renderer.defaultApp+  , Pine.Internal.Renderer.pine+  , module Pine.Internal.Types+  ) where++import Pine.Internal.Renderer+import Pine.Internal.Types

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Pine.Internal.Keyboard+  ( keyboardState+  ) where++import qualified SDL+import Data.Map++data KeyStatus = Pressed | Released | Up | Down deriving (Eq)++keyboardState :: Map SDL.Keycode KeyStatus -> IO (Map SDL.Keycode KeyStatus)+keyboardState pState = do+  kbState <- SDL.getKeyboardState+  let nstate = diff pState (makeState kbState)+  pure nstate++diff :: Map SDL.Keycode KeyStatus -> Map SDL.Keycode KeyStatus -> Map SDL.Keycode KeyStatus+diff = undefined++makeState :: (SDL.Scancode -> Bool) -> Map SDL.Keycode KeyStatus+makeState f = undefined

@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Pine.Internal.Renderer+  ( defaultApp+  , pine+  ) where++import Pine.Internal.Types++import qualified SDL+import qualified SDL.Image as SDLI+import Control.Concurrent.STM++import Data.Text (Text)+import Data.Map (Map)+import qualified Data.Map as M+import Control.Monad+import Data.Word (Word32)++type TextureCache = Map FilePath SDL.Texture++pine :: (Stateful s, Drawable s)+     => Text+     -> SDL.WindowConfig+     -> s+     -> IO ()+pine title windowConfig state_ = do+  SDL.initializeAll+  window <- SDL.createWindow title windowConfig+  renderer <- SDL.createRenderer window (-1) $ SDL.RendererConfig+    { SDL.rendererType = SDL.AcceleratedRenderer+    , SDL.rendererTargetTexture = False+    }+  let+    appLoop :: TextureCache -> IO ()+    appLoop cache = do+      updateQueue <- newTChanIO+      timer <- SDL.addTimer 16 (fpsTimer updateQueue)+      time <- SDL.ticks+      SDL.pollEvent >>= go time updateQueue cache state_+      _ <- SDL.removeTimer timer+      pure ()++    go :: (Stateful s, Drawable s) => Word32 -> TChan () -> TextureCache -> s -> Maybe SDL.Event -> IO ()+    go time updateQueue cache state mevent = do+      time' <- SDL.ticks+      let dt = fromIntegral (time' - time) :: Double+      atomically $ readTChan updateQueue -- not ideal, events could get backed up+      cache' <- drawCanvas cache $ draw state+      case mevent of+        Nothing -> SDL.pollEvent >>= go time' updateQueue cache' (update (DeltaTime dt) state)+        Just ev -> case SDL.eventPayload ev of+          SDL.WindowClosedEvent _ -> pure ()+          _ -> SDL.pollEvent >>= go time' updateQueue cache' (update (SDLEvent ev) state)++    fpsTimer :: TChan () -> Word32 -> IO SDL.RetriggerTimer+    fpsTimer updateQueue _ = do+      atomically $ writeTChan updateQueue ()+      pure $ SDL.Reschedule 16++    drawCanvas :: TextureCache -> Canvas -> IO TextureCache+    drawCanvas cache canvas = do+      SDL.clear renderer+      cache' <- drawCanvas' cache canvas+      SDL.present renderer+      pure cache'++    drawCanvas' :: TextureCache -> Canvas -> IO TextureCache+    drawCanvas' cache canvas = do+      case canvas of+        SingleImage img -> drawImages cache [img]+        Images imgs -> drawImages cache imgs+        EmptyCanvas -> pure cache++    drawImages :: TextureCache -> [Image] -> IO TextureCache+    drawImages cache [] = pure cache+    drawImages cache (img:imgs) =+      case cache M.!? (imageSrc img) of+        Nothing -> do+          tex <- SDLI.loadTexture renderer (imageSrc img)+          SDL.copy renderer tex Nothing Nothing+          drawImages (M.insert (imageSrc img) tex cache) imgs+        Just tex -> do+          SDL.copy renderer tex Nothing Nothing+          drawImages cache imgs++   in appLoop mempty++data DefaultState = Logo Image++instance Stateful DefaultState where+  initial = Logo $ newImage "src/Media/logo.png"+  update = const id++instance Drawable DefaultState where+  draw (Logo img) = fromImage img++defaultApp :: IO ()+defaultApp = pine "Pine" defaultConfig (initial :: DefaultState)+  where+    defaultConfig = SDL.WindowConfig+      { SDL.windowBorder        = True+      , SDL.windowHighDPI       = False+      , SDL.windowInputGrabbed  = False+      , SDL.windowMode          = SDL.Windowed+      , SDL.windowOpenGL        = Nothing+      , SDL.windowPosition      = SDL.Wherever+      , SDL.windowResizable     = True+      , SDL.windowInitialSize   = SDL.V2 800 800+      , SDL.windowVisible       = True+      }++{-+  addEventWatch $ \ev ->+    case eventPayload ev of+      WindowSizeChangedEvent sizeChangeData ->+        putStrLn $ "eventWatch windowSizeChanged: " ++ show sizeChangeData+      KeyboardEvent kev ->+        putStrLn "key event"+      _ -> return ()+  appLoop mempty+    where+      appLoop :: TextureCache -> IO ()+      appLoop tc = pollEvent >>= go tc++      go :: TextureCache -> Maybe Event -> IO ()+      go tc = \case+        Nothing -> pollEvent >>= go tc+        Just ev -> case eventPayload ev of+          KeyboardEvent keyboardEvent+            |  keyboardEventKeyMotion keyboardEvent == Pressed &&+               keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ+            -> return ()+          _ -> pollEvent >>= go tc++++-}

@@ -0,0 +1,39 @@+module Pine.Internal.Types where++import qualified SDL (Event)++import Data.Semigroup++-- DeltaTime Double | KeyPress | KeyRelease | KeyState deriving (Eq, Show) --ideas+data Event = DeltaTime Double | SDLEvent SDL.Event deriving (Eq, Show) --placeholder++class Drawable d where+  draw :: d -> Canvas --Foldable f => d -> f Image++class Stateful s where+  initial :: s+  update  :: Event -> s -> s -- Event -> s -> s++newtype Image = Image+  { imageSrc :: FilePath+  } deriving (Eq, Show) -- put in other info later (like dimensions, quads, etc)++newImage :: FilePath -> Image+newImage = Image++data Canvas = EmptyCanvas | SingleImage Image | Images [Image] deriving (Eq, Show)++instance Semigroup Canvas where+  (<>) (SingleImage img1) (SingleImage img2) = Images [img1,img2]+  (<>) (Images imgs1) (Images imgs2) = Images $ imgs1 <> imgs2+  (<>) (SingleImage img) (Images imgs) = Images $ img:imgs+  (<>) (Images imgs) (SingleImage img) = Images $ imgs <> [img]+  (<>) EmptyCanvas c = c+  (<>) c EmptyCanvas = c++instance Monoid Canvas where+  mempty = EmptyCanvas+  mappend = (<>)++fromImage :: Image -> Canvas+fromImage = SingleImage

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"