animate-preview (empty) → 0.0.0

raw patch · 27 files changed

+1491/−0 lines, 27 filesdep +StateVardep +aesondep +animatesetup-changedbinary-added

Dependencies added: StateVar, aeson, animate, animate-preview, base, bytestring, containers, filepath, fsnotify, key-state, lens, linear, mtl, optparse-applicative, optparse-generic, random, safe, safe-exceptions, sdl2, sdl2-gfx, sdl2-image, sdl2-ttf, text, text-conversions, vector

Files

LICENSE +30/−0
README.md +25/−0
Setup.hs +2/−0
animate-preview.cabal +98/−0
executable/Main.hs +6/−0
library/Animate/Preview.hs +129/−0
library/Animate/Preview/Animation.hs +17/−0
library/Animate/Preview/Color.hs +45/−0
library/Animate/Preview/Config.hs +41/−0
library/Animate/Preview/Frame.hs +11/−0
library/Animate/Preview/Input.hs +39/−0
library/Animate/Preview/Loader.hs +84/−0
library/Animate/Preview/Logger.hs +14/−0
library/Animate/Preview/ManagerInput.hs +81/−0
library/Animate/Preview/Mode.hs +6/−0
library/Animate/Preview/Renderer.hs +153/−0
library/Animate/Preview/Resource.hs +109/−0
library/Animate/Preview/Runner.hs +31/−0
library/Animate/Preview/SDLInput.hs +52/−0
library/Animate/Preview/SDLRenderer.hs +27/−0
library/Animate/Preview/Scalar.hs +43/−0
library/Animate/Preview/Scene.hs +309/−0
library/Animate/Preview/State.hs +45/−0
library/Animate/Preview/Timer.hs +19/−0
package.yaml +65/−0
resource/ProggyClean.ttf binary
stack.yaml +10/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++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 Author name here 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.

+ README.md view

@@ -0,0 +1,25 @@+# Animate Preview++## OSX build++```+brew install sdl2+brew install sdl2_ttf+brew install sdl2_image+brew install sdl2_gfx+stack build+```++## Ubuntu build++```+sudo apt install libsdl2-dev libsdl2-ttf-dev libsdl2-image-dev libsdl2-gfx-dev+stack build+```++## Windows build++```+stack exec -- pacman -S mingw64/mingw-w64-x86_64-pkg-config mingw64/mingw-w64-x86_64-SDL2 mingw64/mingw-w64-x86_64-SDL2_ttf mingw64/mingw-w64-x86_64-SDL2_image mingw64/mingw-w64-x86_64-SDL2_gfx+stack build+```

+ Setup.hs view

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

+ animate-preview.cabal view

@@ -0,0 +1,98 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 51d99c14d61a1d85be7c9e79e08619cb9077082c77d374d45595f5a1cc88b81e++name:           animate-preview+version:        0.0.0+synopsis:       Preview tool for sprite animation+description:    Preview tool for sprite animation+category:       Game+homepage:       https://github.com/jxv/animate-preview#readme+bug-reports:    https://github.com/jxv/animate-preview/issues+maintainer:     Joe Vargas+copyright:      2018 Joe Vargas+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    package.yaml+    README.md+    stack.yaml++data-files:+    resource/ProggyClean.ttf++source-repository head+  type: git+  location: https://github.com/jxv/animate-preview++library+  hs-source-dirs:+      library+  default-extensions: DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase NamedFieldPuns ScopedTypeVariables OverloadedStrings DefaultSignatures MultiParamTypeClasses+  ghc-options: -Wall+  build-depends:+      StateVar+    , aeson+    , animate+    , base >=4.7 && <5+    , bytestring+    , containers+    , filepath+    , fsnotify+    , key-state+    , lens+    , linear+    , mtl+    , optparse-applicative+    , optparse-generic+    , random+    , safe+    , safe-exceptions+    , sdl2+    , sdl2-gfx+    , sdl2-image+    , sdl2-ttf+    , text+    , text-conversions+    , vector+  exposed-modules:+      Animate.Preview+      Animate.Preview.Animation+      Animate.Preview.Color+      Animate.Preview.Config+      Animate.Preview.Frame+      Animate.Preview.Input+      Animate.Preview.Loader+      Animate.Preview.Logger+      Animate.Preview.ManagerInput+      Animate.Preview.Mode+      Animate.Preview.Renderer+      Animate.Preview.Resource+      Animate.Preview.Runner+      Animate.Preview.Scalar+      Animate.Preview.Scene+      Animate.Preview.SDLInput+      Animate.Preview.SDLRenderer+      Animate.Preview.State+      Animate.Preview.Timer+  other-modules:+      Paths_animate_preview+  default-language: Haskell2010++executable animate-preview+  main-is: Main.hs+  hs-source-dirs:+      executable+  default-extensions: DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase NamedFieldPuns ScopedTypeVariables OverloadedStrings DefaultSignatures MultiParamTypeClasses+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      animate-preview+    , base >=4.7 && <5+  other-modules:+      Paths_animate_preview+  default-language: Haskell2010

+ executable/Main.hs view

@@ -0,0 +1,6 @@+module Main where++import qualified Animate.Preview++main :: IO ()+main = Animate.Preview.main

+ library/Animate/Preview.hs view

@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+module Animate.Preview+  ( main+  ) where++import qualified SDL+import qualified SDL.Font as Font+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import Control.Monad.State (MonadState, StateT, evalStateT)+import Control.Monad (when, forever, void)+import Control.Concurrent (threadDelay, forkIO, newMVar)+import Control.Exception.Safe (MonadThrow, MonadCatch)+import Data.Maybe (fromMaybe)+import Data.StateVar (get)+import Options.Generic+import System.FSNotify (withManager, watchDir, eventPath)+import System.FilePath (takeDirectory, takeFileName)++import Animate.Preview.Config+import Animate.Preview.Logger+import Animate.Preview.Loader+import Animate.Preview.Renderer+import Animate.Preview.SDLInput+import Animate.Preview.SDLRenderer+import Animate.Preview.ManagerInput+import Animate.Preview.Resource+import Animate.Preview.Runner+import Animate.Preview.Scene+import Animate.Preview.State+import Animate.Preview.Timer++data Options = Options+  { target :: String  <?> "file path with sprite data (YAML or JSON)"+  , image :: (Maybe String) <?> "Force sprite sheet image path"+  , scale :: (Maybe Float) <?> "Scale the sprite size"+  , highDpi :: Bool <?> "Use high DPI"+  , watch :: Bool <?> "Watch files and reload on change"+  } deriving (Show, Generic)++instance ParseRecord Options where+  parseRecord = parseRecordWithModifiers lispCaseModifiers++main :: IO ()+main = do+  options <- getRecord "options"+  let highDpi' = unHelpful $ highDpi options++  SDL.initialize [SDL.InitVideo]+  Font.initialize+  window <- SDL.createWindow+    "Animate Preview"+    SDL.defaultWindow+      { SDL.windowHighDPI = highDpi'+      , SDL.windowResizable = True+      }+  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer+  resources <- loadResources highDpi' renderer+  loaded <- newMVar Nothing+  current <- newMVar Nothing++  winSize <- fmap fromIntegral <$> get (SDL.windowSize window)+  drawSize <- fmap fromIntegral <$> SDL.glGetDrawableSize window++  let settings = Settings+        { sTarget = unHelpful $ target options+        , sSpritesheet = unHelpful $ image options+        , sScale = fromMaybe 1 (unHelpful $ scale options)+        }++  let cfg = Config+        { cWindow = window+        , cRenderer = renderer+        , cResources = resources+        , cHighDpi = highDpi' && (winSize /= drawSize)+        , cSettings = settings+        , cCurrent = current+        , cLoaded = loaded+        }++  when (unHelpful $ watch options) $ do+    runWatcherAndReloader cfg (sTarget settings)+    case sSpritesheet settings of+      Nothing -> return ()+      Just imgPath -> runWatcherAndReloader cfg imgPath+  +  let v = initVars winSize drawSize+  runAnimatePreview cfg v (reload >> mainLoop)+  SDL.destroyWindow window+  freeResources resources+  Font.quit+  SDL.quit++runWatcherAndReloader :: Config -> String -> IO ()+runWatcherAndReloader cfg filename = void $ forkIO $ withManager $ \mgr -> do+  -- start a watching job (in the background)+  void $ watchDir+    mgr+    (takeDirectory filename)+    (\event -> takeFileName (eventPath event) == takeFileName filename)+    (\_ -> runWatcher cfg reload)+  -- sleep forever (until interrupted)+  forever $ threadDelay 1000000++newtype AnimatePreview a = AnimatePreview (ReaderT Config (StateT Vars IO) a)+  deriving (Functor, Applicative, Monad, MonadReader Config, MonadState Vars, MonadIO, MonadThrow, MonadCatch)++runAnimatePreview :: Config -> Vars -> AnimatePreview a -> IO a+runAnimatePreview config v (AnimatePreview m) = evalStateT (runReaderT m config) v++instance Logger AnimatePreview+instance SDLRenderer AnimatePreview+instance SDLInput AnimatePreview+instance HasInput AnimatePreview+instance Renderer AnimatePreview+instance Scene AnimatePreview+instance Loader AnimatePreview+instance Timer AnimatePreview++newtype Watcher a = Watcher (ReaderT Config IO a)+  deriving (Functor, Applicative, Monad, MonadReader Config, MonadIO, MonadThrow, MonadCatch)++instance Logger Watcher+instance Loader Watcher++runWatcher :: Config -> Watcher a -> IO a+runWatcher cfg (Watcher m) = runReaderT m cfg

+ library/Animate/Preview/Animation.hs view

@@ -0,0 +1,17 @@+module Animate.Preview.Animation where++import qualified Animate+import Text.Printf (printf)++import Data.Aeson (FromJSON, ToJSON)++type Animations key = Animate.Animations key (Animate.SpriteClip key) Seconds++newtype Seconds = Seconds Float+  deriving (Eq, Num, ToJSON, FromJSON, Fractional, Ord)++instance Show Seconds where+  show (Seconds s) = printf "%.3f" s ++ "s"++clamp :: (Fractional a, Ord a) => a -> a -> a -> a+clamp cur min' max' = if cur > max' then max' else (if cur < min' then min' else cur)

+ library/Animate/Preview/Color.hs view

@@ -0,0 +1,45 @@+module Animate.Preview.Color where++import Linear+import Data.Word (Word8)++data Mono+  = Mono'Black+  | Mono'Gray+  | Mono'White+  deriving (Show, Eq, Enum, Bounded)++toggleMono :: Mono -> Mono+toggleMono = \case+  Mono'White -> Mono'Black+  m -> succ m++fromMono :: Mono -> (V4 Word8, V4 Word8)+fromMono = \case+  Mono'White -> (V4 0xff 0xff 0xff 0xff, V4 0xdd 0xdd 0xdd 0xff)+  Mono'Gray -> (V4 0x88 0x88 0x88 0xff, V4 0x66 0x66 0x66 0xff)+  Mono'Black -> (V4 0x22 0x22 0x22 0xff, V4 0x00 0x00 0x00 0xff)++data Color+  = Color'Red+  | Color'Green+  | Color'Blue+  | Color'Magenta+  | Color'Yellow+  | Color'Cyan+  deriving (Show, Eq, Enum, Bounded)++fromColor :: Color -> V4 Word8+fromColor = \case+  Color'Red -> V4 0xff 0x00 0x00 0xff+  Color'Green -> V4 0x00 0xff 0x00 0xff+  Color'Blue -> V4 0x00 0x00 0xff 0xff+  Color'Magenta -> V4 0xff 0x00 0xff 0xff+  Color'Yellow -> V4 0xff 0xff 0x00 0xff+  Color'Cyan -> V4 0x00 0xff 0xff 0xff++toggleColors :: Maybe Color -> Maybe Color+toggleColors Nothing = Just Color'Red+toggleColors (Just c) = case c of+    Color'Cyan -> Nothing+    _ -> Just $ succ c

+ library/Animate/Preview/Config.hs view

@@ -0,0 +1,41 @@+{-# LANGUAGE ConstraintKinds #-}+module Animate.Preview.Config where++import qualified SDL+import qualified Animate+import Data.Text (Text)+import Control.Monad.Reader (MonadReader)+import Control.Concurrent++import Animate.Preview.Animation+import Animate.Preview.Resource++data Settings = Settings+  { sTarget :: String+  , sSpritesheet :: Maybe String+  , sScale :: Float+  }++data Loaded = Loaded+  { lTextToInt :: Text -> Maybe Int+  , lIntToText :: Int -> Text+  , lSpriteSheet :: Animate.SpriteSheet Int SDL.Texture Seconds+  , lTotalKeys :: Int+  }++data Current = Current+  { cPos :: Animate.Position Int Seconds+  , cKeyName :: Text+  } deriving (Show, Eq)++data Config = Config+  { cWindow :: SDL.Window+  , cRenderer :: SDL.Renderer+  , cResources :: Resources+  , cHighDpi :: Bool+  , cSettings :: Settings+  , cCurrent :: MVar (Maybe Current)+  , cLoaded :: MVar (Maybe Loaded)+  }++type R m = MonadReader Config m

+ library/Animate/Preview/Frame.hs view

@@ -0,0 +1,11 @@+module Animate.Preview.Frame where++frameDeltaSeconds :: Fractional a => a+frameDeltaSeconds = 0.016667++frameDeltaMilliseconds :: Int+frameDeltaMilliseconds = 16++msps, fps :: Int+msps = 1000+fps = 60

+ library/Animate/Preview/Input.hs view

@@ -0,0 +1,39 @@+module Animate.Preview.Input where++import KeyState+import Linear++data Input = Input+  { iSpace :: KeyState Int+  , iUp :: KeyState Int+  , iDown :: KeyState Int+  , iLeft :: KeyState Int+  , iRight :: KeyState Int+  , iPrevKeyFrame :: KeyState Int+  , iNextKeyFrame :: KeyState Int+  , iScaleReset :: KeyState Int+  , iScaleMouseUp :: Int+  , iScaleMouseDown :: Int+  , iScaleUp :: KeyState Int+  , iScaleDown :: KeyState Int+  , iEscape :: KeyState Int+  , iReload :: KeyState Int+  , iOrigin :: KeyState Int+  , iOutline :: KeyState Int+  , iBackground :: KeyState Int+  , iMousePos :: V2 Int+  , iMouseClick :: KeyState Int+  , iMouseMiddleClick :: KeyState Int+  , iCenterOrigin :: KeyState Int+  , iAccelReset :: KeyState Int+  , iFaster :: KeyState Int+  , iSlower :: KeyState Int+  , iInfo :: KeyState Int+  , iMode :: KeyState Int+  , iQuit :: Bool+  } deriving (Show, Eq)++initInput :: Input+initInput = Input a a a a a a a a 0 0 a a a a a a a (V2 0 0) a a a a a a a a False+  where+    a = initKeyState

+ library/Animate/Preview/Loader.hs view

@@ -0,0 +1,84 @@+module Animate.Preview.Loader where++import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified SDL+import Control.Monad.IO.Class (MonadIO(..))+import Control.Applicative ((<|>))+import Control.Monad.Reader (asks)+import Control.Concurrent (modifyMVar_, readMVar)+import Data.Text.Conversions (toText)+import Data.Maybe (fromMaybe)+import System.IO.Error++import qualified Animate+import Animate.Preview.Animation+import Animate.Preview.Resource+import Animate.Preview.Config+import Animate.Preview.Logger++class Monad m => Loader m where+  load :: m Bool+  default load :: (R m, MonadIO m, Logger m) => m Bool+  load = do+    ren <- asks cRenderer+    target <- asks (sTarget . cSettings)+    maybeForceImage <- asks (sSpritesheet . cSettings)+    spriteSheetInfo <- liftIO $ catchIOError+      (Just <$> Animate.readSpriteSheetInfoYAML target)+      (const $ return Nothing)+    case spriteSheetInfo :: Maybe (Animate.SpriteSheetInfo Int Seconds) of+      Nothing -> do+        setLoaded Nothing+        logText $ "Not Loaded: " `mappend` toText target+        return False+      Just ssi -> do+        let ssi' = ssi+              { Animate.ssiImage = fromMaybe (Animate.ssiImage ssi) maybeForceImage+              , Animate.ssiAlpha = Nothing <|> Animate.ssiAlpha ssi }+        let animations = Animate.ssiAnimations ssi'+        if Map.null animations+          then do+            setLoaded Nothing+            logText $ "No Animations: " `mappend` toText target+            return False+          else do+            tex' <- liftIO $ loadTexture ren (Animate.ssiImage ssi') (Animate.ssiAlpha ssi')+            case tex' of+              Nothing -> do+                setLoaded Nothing+                logText $ "No Image: " `mappend` toText (Animate.ssiImage ssi')+                return False+              Just tex -> do+                let intToText i = fst $ Map.elemAt i animations+                let textToInt t = Map.lookup t $ Map.fromList $ zip (map fst $ Map.toList animations) [0..]+                let animations' = Animate.Animations $ V.fromList $ do+                      (_  , frames) <- Map.toList animations+                      return $ V.fromList $ do+                        (frameIdx, delay) <- frames+                        return $ Animate.Frame (Animate.ssiClips ssi' !! frameIdx) delay+                let spriteSheet = Animate.SpriteSheet animations' tex+                let totalKeys = V.length $ Animate.unAnimations animations'+                let loaded = Loaded textToInt intToText spriteSheet totalKeys+                setLoaded (Just loaded)+                logText $ "Loaded: " `mappend` toText target+                return True+    where+      loadTexture r path c = do+        s' <- loadSurface' path c+        case s' of+          Nothing -> return Nothing+          Just s -> do+            t <- SDL.createTextureFromSurface r s+            SDL.freeSurface s+            return (Just t)++setLoaded :: (R m, MonadIO m) => Maybe Loaded -> m ()+setLoaded l = do+  m <- asks cLoaded+  liftIO $ modifyMVar_ m (\_ -> return l)++getLoaded :: (R m, MonadIO m) => m (Maybe Loaded)+getLoaded = do+  m <- asks cLoaded+  liftIO $ readMVar m

+ library/Animate/Preview/Logger.hs view

@@ -0,0 +1,14 @@+module Animate.Preview.Logger where++import qualified Data.Text.IO as T+import Control.Monad.IO.Class (MonadIO(..))+import Data.Text (Text)++class Monad m => Logger m where+  logText :: Text -> m ()+  default logText :: MonadIO m => Text -> m ()+  logText = liftIO . T.putStrLn++  logShow :: Show a => a -> m ()+  default logShow :: (MonadIO m, Show a) => a -> m ()+  logShow = liftIO . print

+ library/Animate/Preview/ManagerInput.hs view

@@ -0,0 +1,81 @@+module Animate.Preview.ManagerInput where++import qualified SDL+import Control.Monad.State+import Control.Lens (view)+import KeyState+import Linear++import Animate.Preview.Input+import Animate.Preview.SDLInput+import Animate.Preview.State++class Monad m => HasInput m where+  updateInput :: m ()+  default updateInput :: (HasInput m, SDLInput m, MonadIO m) => m ()+  updateInput = do+    input <- getInput+    events <- pollEventPayloads+    mousePos <- getMousePos+    mouseClick <- getMouseClick+    middleClick <- getMouseMiddleClick+    setInput (stepControl events (mouseClick, middleClick) input) { iMousePos = mousePos }++  setInput :: Input -> m ()+  default setInput :: S m => Input -> m ()+  setInput input = modify (\v -> v { vInput = input })++  getInput :: m Input+  default getInput :: S m => m Input+  getInput = gets vInput++stepControl :: [SDL.EventPayload] -> (Bool, Bool) -> Input -> Input+stepControl events (mouseClick, middleClick) i = i+  { iSpace = next [SDL.KeycodeSpace] iSpace+  , iUp = next [SDL.KeycodeUp, SDL.KeycodeK] iUp+  , iDown = next [SDL.KeycodeDown, SDL.KeycodeJ] iDown+  , iLeft = next [SDL.KeycodeLeft, SDL.KeycodeH] iLeft+  , iRight = next [SDL.KeycodeRight, SDL.KeycodeL] iRight+  , iPrevKeyFrame = next [SDL.KeycodeP] iPrevKeyFrame+  , iNextKeyFrame = next [SDL.KeycodeN] iNextKeyFrame+  , iScaleReset = next [SDL.KeycodeS] iScaleReset+  , iScaleMouseUp = mouseEvent GT+  , iScaleMouseDown = mouseEvent LT+  , iScaleUp = next [SDL.KeycodePlus, SDL.KeycodeEquals] iScaleUp+  , iScaleDown = next [SDL.KeycodeMinus] iScaleDown+  , iEscape = next [SDL.KeycodeEscape] iEscape+  , iReload = next [SDL.KeycodeR] iReload+  , iOrigin = next [SDL.KeycodeT] iOrigin+  , iOutline = next [SDL.KeycodeO] iOutline+  , iBackground = next [SDL.KeycodeB] iBackground+  , iMouseMiddleClick = updateKeyState 1 (iMouseMiddleClick i) middleClick+  , iMouseClick = updateKeyState 1 (iMouseClick i) mouseClick+  , iCenterOrigin = next [SDL.KeycodeC] iCenterOrigin+  , iFaster = next [SDL.KeycodeF] iFaster+  , iSlower = next [SDL.KeycodeD] iSlower+  , iAccelReset = next [SDL.KeycodeA] iAccelReset+  , iInfo = next [SDL.KeycodeI] iInfo+  , iMode = next [SDL.KeycodeM] iMode+  , iQuit = elem SDL.QuitEvent events+  }+  where+    next xs f = nextKeystate events 1 xs (f i)+    mouseEvent ordering = fromIntegral $ maximum $ (0:) $ flip map events $ \case+      SDL.MouseWheelEvent dat -> let+        scrollAmount = view _y $ SDL.mouseWheelEventPos dat+        threshold = 0+        in if abs scrollAmount > threshold+          then case SDL.mouseWheelEventDirection dat of+            SDL.ScrollNormal -> if compare scrollAmount 0 == ordering then abs scrollAmount else 0+            SDL.ScrollFlipped -> if compare 0 scrollAmount == ordering then abs scrollAmount else 0+          else 0+      _ -> 0++nextKeystate :: [SDL.EventPayload] -> Int -> [SDL.Keycode] -> KeyState Int -> KeyState Int+nextKeystate events count keycodes keystate+  | or $ map pressed keycodes = pressedKeyState+  | or $ map released keycodes = releasedKeyState+  | otherwise = maintainKeyState count keystate+  where+    released keycode = or $ map (keycodeReleased keycode) events+    pressed keycode = or $ map (keycodePressed keycode) events

+ library/Animate/Preview/Mode.hs view

@@ -0,0 +1,6 @@+module Animate.Preview.Mode where++data Mode+  = Mode'Playback+  | Mode'Stepper+  deriving (Show, Eq)

+ library/Animate/Preview/Renderer.hs view

@@ -0,0 +1,153 @@+module Animate.Preview.Renderer where++import qualified Animate+import qualified SDL+import qualified SDL.Primitive as Gfx+import qualified Data.Map as Map+import Foreign.C.Types+import SDL.Vect+import Control.Monad.Reader (asks)+import Control.Monad.State (modify)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Maybe (fromMaybe)+import Data.StateVar (($=))+import Foreign.C.Types (CFloat(..))+import Data.Text (Text)+import Data.Text.Conversions (fromText)+import Data.StateVar (get)+import Data.List (foldl')++import Animate.Preview.Config+import Animate.Preview.Resource+import Animate.Preview.Animation+import Animate.Preview.Color+import Animate.Preview.SDLRenderer+import Animate.Preview.State++class Monad m => Renderer m where+  updateScreenInfo :: m ()+  default updateScreenInfo :: (R m, S m, MonadIO m) => m ()+  updateScreenInfo = do+    w <- asks cWindow+    winSize <- liftIO $ get (SDL.windowSize w)+    drawSize <- liftIO $ SDL.glGetDrawableSize w+    modify $ \v -> v { vDrawSize = fromIntegral <$> drawSize, vWinSize = fromIntegral <$> winSize }++  clearScreen :: m ()+  default clearScreen :: (SDLRenderer m, R m) => m ()+  clearScreen = do+    renderer <- asks cRenderer+    clearRenderer renderer++  drawScreen :: m ()+  default drawScreen :: (SDLRenderer m, R m) => m ()+  drawScreen = do+    renderer <- asks cRenderer+    presentRenderer renderer++  drawBackground :: V2 Int -> Mono -> m ()+  default drawBackground :: (SDLRenderer m, R m, MonadIO m) => V2 Int -> Mono -> m ()+  drawBackground (V2 w h) mono = do+    renderer <- asks cRenderer+    let (lite, dark) = fromMono mono+    let indices = do+          x <- [0..(w `div` 10)]+          y <- [0..(h `div` 10)]+          let x0 = x * 10+              x1 = x * 10 + 10+          let y0 = y * 10+              y1 = y * 10 + 10+          let color = if (x + y) `mod` 2 == 0 then lite else dark+          return (V2 x0 y0, V2 x1 y1, color) +    flip mapM_ indices $ \(a,b,c) ->+      liftIO $ Gfx.fillRectangle renderer (fromIntegral <$> a) (fromIntegral <$> b) c+  +  drawAniSprite :: Animate.SpriteSheet Int SDL.Texture Seconds -> Maybe Color -> Float -> Animate.SpriteClip Int -> (Int, Int) -> m ()+  default drawAniSprite :: (SDLRenderer m, R m, MonadIO m) => Animate.SpriteSheet Int SDL.Texture Seconds -> Maybe Color -> Float -> Animate.SpriteClip Int -> (Int, Int) -> m ()+  drawAniSprite as = drawSprite (const as)++  drawCrosshair :: (Int, Int) -> Color -> m ()+  default drawCrosshair :: (MonadIO m, R m) => (Int, Int) -> Color -> m ()+  drawCrosshair (x,y) color = do+    ren <- asks cRenderer+    let radius = 8+    let diameter = fromIntegral $ radius * 2+    liftIO $ do+      let color' = fromColor color+      Gfx.horizontalLine ren (fromIntegral <$> V2 (x - radius) y) diameter color'+      Gfx.verticalLine ren (fromIntegral <$> V2 x (y - radius)) diameter color'++  drawText :: (Int, Int) -> Text -> m ()+  default drawText :: (SDLRenderer m, R m, MonadIO m) => (Int, Int) -> Text -> m ()+  drawText xy text = do+    glyphMap <- asks (rGlyphMap . cResources)+    glyphSize <- asks (rGlyphSize . cResources)+    let instructions = buildGlyphIntructions glyphSize glyphMap (fromText text)+    let (x,y) = xy+    flip mapM_ instructions $ \(tex, (x',y')) -> do+      let xy' = (x + x', y + y')+      drawTextureSprite (const tex) xy'++buildGlyphIntructions :: Int -> Map.Map Char Glyph -> [Char] -> [(SDL.Texture, (Int, Int))]+buildGlyphIntructions _glyphSize glyphMap str = fst $ foldl' appendGlyph ([], (0,0)) str+  where+    appendGlyph+      :: ([(SDL.Texture, (Int, Int))], (Int,Int))+      -> Char+      -> ([(SDL.Texture, (Int, Int))], (Int,Int)) +    appendGlyph (glyphs, (x,y)) ch = case Map.lookup ch glyphMap of+      Nothing -> (glyphs, (x,y))+      Just glyph -> let+        tex = gTexture glyph+        (xmin, _xmax, _ymin, _ymax, adv) = gMetrics glyph+        x' = x + xmin+        y' = y+        in ((tex, (x', y')) : glyphs, (x + xmin + adv, y))++drawTextureSprite :: (SDLRenderer m, R m) => (Config -> SDL.Texture) -> (Int, Int) -> m ()+drawTextureSprite getTex (x,y) = do+  renderer <- asks cRenderer+  tex <- asks getTex+  SDL.TextureInfo{textureWidth,textureHeight} <- queryTexture tex+  let dim = V2 textureWidth textureHeight+  drawTexture+    renderer+    tex+    Nothing+    (Just $ SDL.Rectangle (SDL.P $ SDL.V2 (fromIntegral x) (fromIntegral y)) dim)++drawSprite :: (SDLRenderer m, R m, MonadIO m) => (Config -> Animate.SpriteSheet key SDL.Texture Seconds) -> Maybe Color -> Float -> Animate.SpriteClip key -> (Int, Int) -> m ()+drawSprite ss outline scalar' clip (x,y) = do+  let scalar = pure (CFloat scalar')+  renderer <- asks cRenderer+  sheet <- asks (Animate.ssImage . ss)+  let scaleDown n = fmap round $ (fmap fromIntegral n) / scalar+  let scaleUp n = fmap round $ (fmap fromIntegral n) * scalar+  let clip'@(SDL.Rectangle _ dim) = rectFromClip clip+  let offset = offsetFromClip clip+  let loc = (+) <$> offset <*> (scaleDown $ V2 x y)+  case outline of+    Nothing -> return ()+    Just outline' -> liftIO $ Gfx.rectangle renderer (scaleUp loc) (scaleUp $ loc + dim) (fromColor outline')+  -- set scale for sprite+  liftIO $ SDL.rendererScale renderer $= scalar+  drawTexture+    renderer+    sheet+    (Just clip')+    (Just $ SDL.Rectangle (SDL.P loc) dim)+  -- reset scale from sprite+  liftIO $ SDL.rendererScale renderer $= (V2 1 1)++getSpriteAnimations :: R m => (Config -> Animate.SpriteSheet key SDL.Texture Seconds) -> m (Animations key)+getSpriteAnimations ss = asks (Animate.ssAnimations . ss)++rectFromClip :: Animate.SpriteClip key -> SDL.Rectangle CInt+rectFromClip Animate.SpriteClip{scX,scY,scW,scH} = SDL.Rectangle (SDL.P (V2 (num scX) (num scY))) (V2 (num scW) (num scH))+  where+    num = fromIntegral++offsetFromClip :: Animate.SpriteClip key -> V2 CInt+offsetFromClip Animate.SpriteClip{scOffset} = fromMaybe+  (V2 0 0)+  ((\(x,y) -> fromIntegral <$> V2 (-x) (-y)) <$> scOffset)

+ library/Animate/Preview/Resource.hs view

@@ -0,0 +1,109 @@+module Animate.Preview.Resource where++import qualified SDL+import qualified SDL.Font as Font+import qualified SDL.Image as Image+import qualified Animate+import qualified SDL.Raw.Video as Raw+import qualified SDL.Internal.Numbered as Numbered+import qualified Data.Map as Map+import Control.Monad (filterM)+import Data.Text (Text)+import Data.Maybe (catMaybes)+import Data.StateVar (($=))+import SDL.Vect+import System.IO.Error (catchIOError)+import Paths_animate_preview (getDataFileName)++data Resources = Resources+  { rFont :: Font.Font+  , rGlyphMap :: Map.Map Char Glyph+  , rGlyphSize :: Int+  }++data Glyph = Glyph+  { gChar :: Char+  , gMetrics :: (Int, Int, Int, Int, Int)+  , gTexture :: SDL.Texture+  }++-- | Produce a new 'SDL.Surface' based on an existing one, but+-- optimized for blitting to the specified 'SDL.PixelFormat'.+convertSurface :: SDL.Surface -> SDL.PixelFormat -> IO SDL.Surface+convertSurface (SDL.Surface s _) pixFmt = do+  fmt <- Raw.allocFormat (Numbered.toNumber pixFmt)+  surface <- SDL.Surface <$> Raw.convertSurface s fmt 0 <*> pure Nothing+  surface <$ Raw.freeFormat fmt++loadSurface' :: FilePath -> Maybe Animate.Color -> IO (Maybe SDL.Surface)+loadSurface' path alpha = do+  surface0' <- catchIOError+    (Just <$> Image.load path)+    (const $ return Nothing)+  case surface0' of+    Nothing -> return Nothing+    Just surface0 -> do+      surface <- convertSurface surface0 SDL.RGBA8888+      SDL.freeSurface surface0+      case alpha of+        Just (r,g,b) -> SDL.surfaceColorKey surface $= (Just $ V4 r g b 0x00)+        Nothing -> return ()+      return (Just surface)++alphaColorDef :: Animate.Color+alphaColorDef = (0xff,0x00,0xff)++createText :: Bool -> SDL.Renderer -> Font.Font -> Text -> IO SDL.Texture+createText highDpi ren font text = do+  Font.setHinting font Font.None+  Font.setOutline font (if highDpi then 4 else 2)+  outline <- Font.solid font (V4 0 0 0 0) text+  Font.setOutline font 0+  inline <- Font.solid font (V4 255 255 255 255) text+  _ <- SDL.surfaceBlit inline Nothing outline (Just $ SDL.P (if highDpi then 4 else 2))+  tex <- SDL.createTextureFromSurface ren outline+  SDL.freeSurface inline+  SDL.freeSurface outline+  return tex++createGlyph :: Bool -> SDL.Renderer -> Font.Font -> Char -> IO (Maybe Glyph)+createGlyph highDpi ren font ch = do+  metrics' <- Font.glyphMetrics font ch+  --+  case metrics' of+    Nothing -> return Nothing+    Just metrics@(xmin, xmax, _ymin, _ymax, _adv) -> do+      if (xmax - xmin > 0) || ch == ' '+        then do+          Font.setHinting font Font.None+          Font.setOutline font (if highDpi then 4 else 2)+          outline <- Font.solidGlyph font (V4 0 0 0 0) ch+          Font.setOutline font 0+          inline <- Font.solidGlyph font (V4 255 255 255 255) ch+          _ <- SDL.surfaceBlit inline Nothing outline (Just $ SDL.P (if highDpi then 4 else 2))+          tex <- SDL.createTextureFromSurface ren outline+          SDL.freeSurface inline+          SDL.freeSurface outline+          --+          return . Just $ Glyph ch metrics tex+        else return Nothing++loadResources :: Bool -> SDL.Renderer -> IO Resources+loadResources highDpi ren = do+  fileName <- getDataFileName "resource/ProggyClean.ttf"+  let glyphSize = if highDpi then 32 else 16+  font <- Font.load fileName glyphSize+  putStrLn "Font cache: filtering glyphs"+  availableChars <- filterM (Font.glyphProvided font) [minBound..maxBound]+  putStrLn "Font cache: creating textures"+  glyphs <- mapM (createGlyph highDpi ren font) (' ':availableChars)+  let glyphs' = map (\g -> (gChar g, g)) (catMaybes glyphs)+  return Resources+    { rFont = font+    , rGlyphMap = Map.fromList glyphs'+    , rGlyphSize = glyphSize+    }++freeResources :: Resources -> IO ()+freeResources r = do+  Font.free (rFont r)

+ library/Animate/Preview/Runner.hs view

@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+module Animate.Preview.Runner where++import Control.Monad (unless)+import Control.Monad.State (gets)+import KeyState++import Animate.Preview.Config+import Animate.Preview.Logger+import Animate.Preview.Renderer+import Animate.Preview.Input+import Animate.Preview.Scene+import Animate.Preview.ManagerInput+import Animate.Preview.State+import Animate.Preview.Timer++mainLoop :: (R m, S m, Logger m, Renderer m, HasInput m, Scene m, Timer m) => m ()+mainLoop = do+  ticks <- startTicks+  updateScreenInfo+  drawSize <- gets vDrawSize+  background <- gets vBackground+  updateInput+  input <- getInput+  clearScreen+  drawBackground drawSize background+  sceneStep+  drawScreen+  let quit = iQuit input || ksStatus (iEscape input) == KeyStatus'Pressed+  delayTicks ticks+  unless quit mainLoop

+ library/Animate/Preview/SDLInput.hs view

@@ -0,0 +1,52 @@+module Animate.Preview.SDLInput where++import qualified SDL+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.State (gets)+import Linear++import Animate.Preview.State++keycodePressed :: SDL.Keycode -> SDL.EventPayload -> Bool+keycodePressed keycode event = case event of+  SDL.KeyboardEvent SDL.KeyboardEventData{keyboardEventKeysym = SDL.Keysym{keysymKeycode = code}, keyboardEventKeyMotion = motion, keyboardEventRepeat } ->+    code == keycode &&+    motion == SDL.Pressed &&+    not keyboardEventRepeat+  _ -> False++keycodeReleased :: SDL.Keycode -> SDL.EventPayload -> Bool+keycodeReleased keycode event = case event of+  SDL.KeyboardEvent SDL.KeyboardEventData{keyboardEventKeysym = SDL.Keysym{keysymKeycode = code}, keyboardEventKeyMotion = motion, keyboardEventRepeat } ->+    code == keycode &&+    motion == SDL.Released &&+    not keyboardEventRepeat+  _ -> False++class Monad m => SDLInput m where+  pollEventPayloads :: m [SDL.EventPayload]+  default pollEventPayloads :: MonadIO m => m [SDL.EventPayload]+  pollEventPayloads = liftIO $ map SDL.eventPayload <$> SDL.pollEvents++  getMousePos :: m (V2 Int)+  default getMousePos :: (S m, MonadIO m) => m (V2 Int)+  getMousePos = do+    drawSize <- gets vDrawSize+    winSize <- gets vWinSize+    SDL.P pos <- liftIO SDL.getAbsoluteMouseLocation+    let pos' = div <$> ((*) <$> drawSize <*> (fmap fromIntegral pos)) <*> winSize+    return $ fmap fromIntegral pos'++  getMouseClick :: m Bool+  default getMouseClick :: MonadIO m => m Bool+  getMouseClick = do+    test <- liftIO SDL.getMouseButtons+    return $ test (SDL.ButtonExtra 0)+    -- There's an offby one bug in `sdl2` which doesn't test SDL.ButtonLeft as expected+    -- It has been since fixed but not uploaded to hackage: https://github.com/haskell-game/sdl2/commit/eb7accdc2ae6349f262e758a93e5c62ee75d0e14++  getMouseMiddleClick :: m Bool+  default getMouseMiddleClick :: MonadIO m => m Bool+  getMouseMiddleClick = do+    test <- liftIO SDL.getMouseButtons+    return $ test (SDL.ButtonExtra 1) -- Same comment as above

+ library/Animate/Preview/SDLRenderer.hs view

@@ -0,0 +1,27 @@+module Animate.Preview.SDLRenderer where++import qualified SDL+import Data.StateVar (($=))+import Control.Monad.IO.Class (MonadIO(..))+import Foreign.C.Types+import SDL.Vect+import Control.Monad (void)++class Monad m => SDLRenderer m where+  presentRenderer :: SDL.Renderer -> m ()+  default presentRenderer :: MonadIO m => SDL.Renderer -> m ()+  presentRenderer = SDL.present++  clearRenderer :: SDL.Renderer -> m ()+  default clearRenderer :: MonadIO m => SDL.Renderer -> m ()+  clearRenderer ren = do+    SDL.rendererDrawColor ren $= V4 0x00 0x00 0x00 0xff+    liftIO $ void $ SDL.clear ren++  queryTexture :: SDL.Texture -> m SDL.TextureInfo+  default queryTexture ::  MonadIO m => SDL.Texture -> m SDL.TextureInfo+  queryTexture = SDL.queryTexture++  drawTexture :: SDL.Renderer -> SDL.Texture -> Maybe (SDL.Rectangle CInt)-> Maybe (SDL.Rectangle CInt) -> m ()+  default drawTexture :: MonadIO m => SDL.Renderer -> SDL.Texture -> Maybe (SDL.Rectangle CInt) -> Maybe (SDL.Rectangle CInt) -> m ()+  drawTexture renderer tex maybeClip maybeLoc = SDL.copy renderer tex maybeClip maybeLoc

+ library/Animate/Preview/Scalar.hs view

@@ -0,0 +1,43 @@+module Animate.Preview.Scalar where++data Scalar+  = Scalar'None+  | Scalar'Down Int+  | Scalar'Up Int+  deriving (Show, Eq)++scalarToSeconds :: Scalar -> Float+scalarToSeconds = \case+  Scalar'None -> 1+  Scalar'Down n -> 1 - (0.1 * fromIntegral n)+  Scalar'Up n -> 1 + (0.5 * fromIntegral n)++asSpeedString :: Scalar -> String+asSpeedString = \case+  Scalar'None -> "1x"+  Scalar'Down n -> "0." ++ show (10 - n) ++ "x"+  Scalar'Up n -> show (n `div` 2 + 1) ++ "." ++ (if mod n 2 == 0 then  "0" else "5") ++ "x"++scalarToSpriteScale :: Scalar -> Float+scalarToSpriteScale = \case+  Scalar'None -> 1+  Scalar'Down n -> 1 - (0.1 * fromIntegral n)+  Scalar'Up n -> 1 + (0.1 * fromIntegral n)++asScaleString :: Scalar -> String+asScaleString = \case+  Scalar'None -> "1x"+  Scalar'Down n -> "0." ++ show (10 - n) ++ "x"+  Scalar'Up n -> show (n `div` 10 + 1) ++ "." ++ show (mod n 10) ++ "x"++incrementScalar :: Int -> Scalar -> Scalar+incrementScalar upper = \case+  Scalar'None -> Scalar'Up 1+  Scalar'Up n -> Scalar'Up (min upper (n + 1))+  Scalar'Down n -> if n <= 1 then Scalar'None else Scalar'Down (n - 1)++decrementScalar :: Int -> Scalar -> Scalar+decrementScalar lower = \case+  Scalar'None -> Scalar'Down 1+  Scalar'Down n -> Scalar'Down (min lower (n + 1))+  Scalar'Up n -> if n <= 1 then Scalar'None else Scalar'Up (n - 1)

+ library/Animate/Preview/Scene.hs view

@@ -0,0 +1,309 @@+module Animate.Preview.Scene where++import qualified Animate+import qualified Data.Vector as V+import Control.Concurrent (readMVar, modifyMVar_)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Reader (asks)+import Control.Monad.State (modify, gets)+import Data.Text.Conversions (toText, fromText)+import KeyState+import Linear++import Animate.Preview.Animation+import Animate.Preview.Config+import Animate.Preview.Renderer+import Animate.Preview.Input+import Animate.Preview.Frame+import Animate.Preview.State+import Animate.Preview.ManagerInput+import Animate.Preview.Color+import Animate.Preview.Logger+import Animate.Preview.Scalar+import Animate.Preview.Mode+import Animate.Preview.Loader++class Monad m => Scene m where+  sceneStep :: m ()+  default sceneStep :: (R m, S m, Renderer m, HasInput m, Logger m, Loader m, MonadIO m) => m ()+  sceneStep = do+    updateMode+    updateReload+    toggleVisuals+    updateOrigin+    updateKeyFrame+    updateSpeed+    updateScale+    updateInfo+    updateAnimation+    drawScene++updateKeyFrame :: (R m, HasInput m, MonadIO m) => m ()+updateKeyFrame = do+  input <- getInput+  loaded' <- getLoaded +  case loaded' of+    Nothing -> return ()+    Just loaded -> do+      let animations = (Animate.ssAnimations . lSpriteSheet) loaded+      when (isPressed $ iNextKeyFrame input) $ modifyCurrent' $ \c -> let+        key = unsafeNextKey (Animate.pKey $ cPos c) animations+        keyName = lIntToText loaded key+        in Current (Animate.initPosition key) keyName+      when (isPressed $ iPrevKeyFrame input) $ modifyCurrent' $ \c -> let+        key = unsafePrevKey (Animate.pKey $ cPos c) animations+        keyName = lIntToText loaded key+        in Current (Animate.initPosition key) keyName++unsafeNextKey :: Int -> Animate.Animations a b c -> Int+unsafeNextKey n (Animate.Animations a) = (1 + n) `mod` (V.length a)++unsafePrevKey :: Int -> Animate.Animations a b c -> Int+unsafePrevKey n (Animate.Animations a) = (n - 1) `mod` (V.length a)++updateMode :: (S m, HasInput m) => m ()+updateMode = do+  input <- getInput+  when (onceThenFire $ iMode input) $ modify $ \v -> v { vMode = if vMode v == Mode'Playback then Mode'Stepper else Mode'Playback }++updateReload :: (S m, R m, HasInput m, Loader m, MonadIO m) => m ()+updateReload = do+  input <- getInput+  when (isPressed $ iReload input)reload++reload :: (R m, Loader m, MonadIO m) => m ()+reload = do+  _ <- load+  loaded' <- getLoaded+  case loaded' of+    Nothing -> return ()+    Just loaded -> do+      modifyCurrent $ \current ->+        case current of+          Nothing -> Just $ Current (Animate.initPosition 0) (lIntToText loaded 0)+          Just c -> Just $ reloadCurrent loaded c++reloadCurrent :: Loaded -> Current -> Current+reloadCurrent l c+  | lIntToText l (Animate.pKey . cPos $ c) == cKeyName c = case lTextToInt l (cKeyName c) of+      Nothing -> reset+      Just k -> c+        { cPos = (cPos c)+            { Animate.pKey = k+            , Animate.pFrameIndex = mod+                (Animate.pFrameIndex (cPos c))+                (V.length $ Animate.framesByAnimation (Animate.ssAnimations $ lSpriteSheet l) k)+            , Animate.pCounter = 0+            }+        }+  | otherwise = reset+  where+    reset = Current (Animate.initPosition 0) (lIntToText l 0)++updateAnimation :: (R m, S m, Renderer m, HasInput m, MonadIO m) => m ()+updateAnimation = do+  mode <- gets vMode+  loaded' <- getLoaded +  case loaded' of+    Nothing -> return ()+    Just loaded -> do+      let animations = (Animate.ssAnimations . lSpriteSheet) loaded+      current' <- getCurrent+      case current' of+        Nothing -> return ()+        Just Current{cPos=pos} -> case mode of+          Mode'Stepper -> do+            input <- getInput+            when (onceThenFire $ iFaster input) $ modifyCurrent' $ \c -> c { cPos = forceNextFrameIndex animations pos }+            when (onceThenFire $ iSlower input) $ modifyCurrent' $ \c -> c { cPos = forcePrevFrameIndex animations pos }+          Mode'Playback -> do+            accel <- gets vAccel+            let accelScalar = scalarToSeconds accel+            let pos' = Animate.stepPosition animations pos (frameDeltaSeconds * (Seconds accelScalar))+            modifyCurrent' $ \c -> c { cPos = pos' }++unsafeForceNextFrameIndex :: V.Vector (Animate.Frame loc delay) -> Animate.FrameIndex -> Animate.FrameIndex+unsafeForceNextFrameIndex frames idx = if idx + 1 >= len then 0 else idx + 1+  where len = V.length frames++unsafeForcePrevFrameIndex :: V.Vector (Animate.Frame loc delay) -> Animate.FrameIndex -> Animate.FrameIndex+unsafeForcePrevFrameIndex frames idx = if idx <= 0 then len - 1 else idx - 1+  where len = V.length frames++forceNextFrameIndex :: Enum key => Animate.Animations key loc delay -> Animate.Position key delay -> Animate.Position key delay+forceNextFrameIndex a p = p { Animate.pFrameIndex = unsafeForceNextFrameIndex frames (Animate.pFrameIndex p) }+  where+    frames = Animate.framesByAnimation a (Animate.pKey p)++forcePrevFrameIndex :: Enum key => Animate.Animations key loc delay -> Animate.Position key delay -> Animate.Position key delay+forcePrevFrameIndex a p = p { Animate.pFrameIndex = unsafeForcePrevFrameIndex frames (Animate.pFrameIndex p) }+  where+    frames = Animate.framesByAnimation a (Animate.pKey p)++updateSpeed :: (S m, HasInput m) => m ()+updateSpeed = do+  input <- getInput+  mode <- gets vMode+  case mode of+    Mode'Stepper -> return ()+    Mode'Playback ->  do+      let up = onceThenFire (iFaster input) +      let down = onceThenFire (iSlower input)+      let reset = isPressed (iAccelReset input)+      let change s+            | reset = Scalar'None+            | up && not down = incrementScalar 18 s+            | down && not up = decrementScalar 9 s+            | otherwise = s+      modify $ \v -> v { vAccel = change (vAccel v) }++onceThenFire :: KeyState Int -> Bool+onceThenFire ks = isPressed ks || (isHeld ks && counterGreater 20 ks)++counterGreater :: Int -> KeyState Int -> Bool  +counterGreater n ks = case ksCounter ks of+  Nothing -> False+  Just counter -> counter > n++updateInfo :: (S m, HasInput m) => m ()+updateInfo = do+  input <- getInput+  when (onceThenFire $ iInfo input) $ modify $ \v -> v { vInfoShown = not (vInfoShown v) }++updateScale :: (S m, HasInput m) => m ()+updateScale = do+  input <- getInput+  let up = onceThenFire (iScaleUp input) || iScaleMouseUp input > 0+  let down = onceThenFire (iScaleDown input) || iScaleMouseDown input > 0+  let reset = isPressed (iScaleReset input) || isPressed (iMouseMiddleClick input)+  let increment = replicate (max 1 (iScaleMouseUp input)) (incrementScalar 90)+  let decrement = replicate (max 1 (iScaleMouseDown input)) (decrementScalar 9)+  let change s+        | reset = Scalar'None+        | up && not down = fapply increment s+        | down && not up = fapply decrement s+        | otherwise = s+  modify $ \v -> v { vScale = change (vScale v) }++modifyCurrent' :: (R m, MonadIO m) => (Current -> Current) -> m ()+modifyCurrent' f = do+  m <- asks cCurrent+  liftIO $ modifyMVar_ m (\c -> return $ fmap f c)++modifyCurrent :: (R m, MonadIO m) => (Maybe Current -> Maybe Current) -> m ()+modifyCurrent f = do+  m <- asks cCurrent+  liftIO $ modifyMVar_ m (\c -> return $ f c)++setCurrent :: (R m, MonadIO m) => Maybe Current -> m ()+setCurrent c = do+  m <- asks cCurrent+  liftIO $ modifyMVar_ m (\_ -> return c)++getCurrent :: (R m, MonadIO m) => m (Maybe Current)+getCurrent = do+  m <- asks cCurrent+  liftIO $ readMVar m++fapply :: [a -> a] -> a -> a+fapply xs a = case xs of [] -> a; (y:ys) -> fapply ys (y a)++updateOrigin :: (R m, S m, HasInput m) => m ()+updateOrigin = do+  input <- getInput+  -- Move with keys+  let d = 5+  when (onceThenFire $ iUp input) $ modify $ \v -> v { vOrigin = vOrigin v + V2 0 (-d) }+  when (onceThenFire $ iDown input) $ modify $ \v -> v { vOrigin = vOrigin v + V2 0 d }+  when (onceThenFire $ iLeft input) $ modify $ \v -> v { vOrigin = vOrigin v + V2 (-d) 0 }+  when (onceThenFire $ iRight input) $ modify $ \v -> v { vOrigin = vOrigin v + V2 d 0 }+  -- Recenter origin+  when (isPressed $ iCenterOrigin input) $ do+    drawSize <- gets vDrawSize+    modify $ \v -> v { vOrigin = div <$> drawSize <*> 2 }+  -- Origin by mouse click+  when (isTouched $ iMouseClick input) $ modify $ \v -> v+   { vOrigin = iMousePos input }++toggleVisuals :: (S m, HasInput m) => m ()+toggleVisuals = do+  input <- getInput+  let toggleBackground = isPressed (iBackground input)+  let toggleOrigin = isPressed (iOrigin input)+  let toggleOutline = isPressed (iOutline input)+  modify $ (\v -> v+    { vBackground = (if toggleBackground then toggleMono else id) (vBackground v)+    , vOriginColor = (if toggleOrigin then toggleColors else id) (vOriginColor v)+    , vOutlineColor = (if toggleOutline then toggleColors else id) (vOutlineColor v)+    })++drawScene :: (R m, S m, Renderer m, HasInput m, MonadIO m) => m ()+drawScene = do+  V2 x y <- gets vOrigin+  current <- getCurrent+  originColor <- gets vOriginColor+  outlineColor <- gets vOutlineColor+  accel <- gets vAccel+  mode <- gets vMode+  infoShown <- gets vInfoShown+  scale <- gets vScale+  let scalar = scalarToSpriteScale scale+  loaded' <- getLoaded +  highDpi <- asks cHighDpi+  let lineSpacing = lineSpacing' highDpi+  case loaded' of+    Nothing -> when infoShown $ do+      drawText (ofsX, ofsY + lineSpacing * 4)  $ toText $ concat ["Anim:"]+      drawText (ofsX, ofsY + lineSpacing * 5)  $ toText $ concat ["  Key:"]+      drawText (ofsX, ofsY + lineSpacing * 6)  $ toText $ concat ["  Time:"]+      drawText (ofsX, ofsY + lineSpacing * 7)  $ toText $ concat ["Pos:"]+      drawText (ofsX, ofsY + lineSpacing * 8)  $ toText $ concat ["  Frame:"]+      drawText (ofsX, ofsY + lineSpacing * 9)  $ toText $ concat ["  Time:"]+      drawText (ofsX, ofsY + lineSpacing * 10) $ toText $ concat ["  Points:"]+      drawText (ofsX, ofsY + lineSpacing * 11) $ toText $ concat ["  Size:"]+      drawText (ofsX, ofsY + lineSpacing * 12) $ toText $ concat ["  Offset: "]+    Just loaded -> do+      case current of+        Nothing -> return ()+        Just c -> do+          let pos = cPos c+          let animations = (Animate.ssAnimations . lSpriteSheet) loaded+          let frames = Animate.framesByAnimation animations (Animate.pKey pos)+          let frame = frames V.! Animate.pFrameIndex pos+          let frameDelay = Animate.fDelay frame+          let frameClip = Animate.fLocation frame+          let (x0,y0) = (Animate.scX frameClip, Animate.scY frameClip)+          let (w,h) = (Animate.scW frameClip, Animate.scH frameClip)+          let (x1,y1) = (x0 + w, y0 + h)+          let framesLen = V.length frames+          let totalSeconds = sum $ map Animate.fDelay (V.toList frames)+          let loc = Animate.currentLocation animations pos+          drawAniSprite (lSpriteSheet loaded) outlineColor scalar loc (x, y)+          when infoShown $ do+            let keyName = cKeyName c+            drawText (ofsX, ofsY + lineSpacing * 4)  $ toText $ concat ["Anim:"]+            drawText (ofsX, ofsY + lineSpacing * 5)  $ toText $ concat ["  Key: \"", fromText keyName, "\" ", show $ Animate.pKey pos, " [", show $ lTotalKeys loaded - 1, "]"]+            drawText (ofsX, ofsY + lineSpacing * 6)  $ toText $ concat ["  Time: ", show totalSeconds]+            drawText (ofsX, ofsY + lineSpacing * 7)  $ toText $ concat ["Pos:"]+            drawText (ofsX, ofsY + lineSpacing * 8)  $ toText $ concat ["  Frame: ", show $ Animate.pFrameIndex pos,  " [", show $ framesLen - 1, "]"]+            drawText (ofsX, ofsY + lineSpacing * 9)  $ toText $ concat ["  Time: ", show $ Animate.pCounter pos, " [", show $ frameDelay, "]"]+            drawText (ofsX, ofsY + lineSpacing * 10) $ toText $ concat ["  Points: (", show x0, ",", show y0, ") (", show x1, ",", show y1, ")"]+            drawText (ofsX, ofsY + lineSpacing * 11) $ toText $ concat ["  Size: (", show w, ",", show h, ")"]+            drawText (ofsX, ofsY + lineSpacing * 12) $ toText $ concat $ ["  Offset: "] ++ case Animate.scOffset frameClip of+              Nothing -> []+              Just (ox,oy) -> ["(", show ox, ",", show oy, ")"]+  case originColor of+    Nothing -> return ()+    Just originColor' -> drawCrosshair (x,y) originColor'+  -- HUD+  when infoShown $ do+    settings <- asks cSettings+    drawText (ofsX, ofsY + lineSpacing * 0) ("Mode: " `mappend` if mode == Mode'Playback then "Playback" else "Stepper")+    drawText (ofsX, ofsY + lineSpacing * 1) ("File: " `mappend` toText (sTarget settings))+    drawText (ofsX, ofsY + lineSpacing * 2) ("Scale: " `mappend` toText (asScaleString scale))+    drawText (ofsX, ofsY + lineSpacing * 3) ("Accel: " `mappend` toText (asSpeedString accel))+  where+    lineSpacing' x = if x then 26 else 13+    ofsX = 6+    ofsY = 6

+ library/Animate/Preview/State.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+module Animate.Preview.State where++import Control.Lens+import Control.Monad.State (MonadState)+import Linear++import Animate.Preview.Input+import Animate.Preview.Color+import Animate.Preview.Scalar+import Animate.Preview.Mode++data Vars = Vars+  { vInput :: Input+  , vBackground :: Mono+  , vOriginColor :: Maybe Color+  , vOutlineColor :: Maybe Color+  , vOrigin :: V2 Int+  , vAccel :: Scalar+  , vScale :: Scalar+  , vInfoShown :: Bool+  , vMode :: Mode+  , vDrawSize :: V2 Int+  , vWinSize :: V2 Int+  }++initVars :: V2 Int -> V2 Int -> Vars+initVars winSize drawSize = Vars+  { vInput = initInput+  , vBackground = Mono'Gray+  , vOriginColor = Just Color'Red+  , vOutlineColor = Just Color'Green+  , vOrigin = div <$> drawSize <*> 2+  , vAccel = Scalar'None+  , vScale = Scalar'None+  , vInfoShown = True+  , vMode = Mode'Playback+  , vWinSize = winSize+  , vDrawSize = drawSize+  }++makeClassy ''Vars++type S m = MonadState Vars m

+ library/Animate/Preview/Timer.hs view

@@ -0,0 +1,19 @@+module Animate.Preview.Timer where++import qualified SDL+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (when)++import Animate.Preview.Frame++class Monad m => Timer m where+  startTicks :: m Int+  default startTicks :: MonadIO m => m Int+  startTicks = fromIntegral <$> liftIO SDL.ticks++  delayTicks :: Int -> m ()+  default delayTicks :: MonadIO m => Int -> m ()+  delayTicks start = liftIO $ do+    end <- fromIntegral <$> SDL.ticks+    let ms = (msps - (end -start) * fps) `div` fps+    when (ms > 0) (SDL.delay $ fromIntegral ms)

+ package.yaml view

@@ -0,0 +1,65 @@+name: animate-preview+version: '0.0.0'+github: jxv/animate-preview+license: BSD3+category: Game+synopsis: Preview tool for sprite animation+description: Preview tool for sprite animation+maintainer: Joe Vargas+copyright: 2018 Joe Vargas+data-files:+- resource/ProggyClean.ttf+extra-source-files:+- package.yaml+- README.md+- stack.yaml+ghc-options: -Wall+default-extensions:+- DuplicateRecordFields+- FlexibleContexts+- FlexibleInstances+- GeneralizedNewtypeDeriving+- LambdaCase+- NamedFieldPuns+- ScopedTypeVariables+- OverloadedStrings+- DefaultSignatures+- MultiParamTypeClasses+library:+  dependencies:+    - base >=4.7 && <5+    - aeson+    - animate+    - bytestring+    - containers+    - filepath+    - fsnotify+    - key-state+    - linear+    - lens+    - mtl+    - optparse-applicative+    - optparse-generic+    - random+    - safe+    - safe-exceptions+    - sdl2+    - sdl2-image+    - sdl2-ttf+    - sdl2-gfx+    - StateVar+    - text+    - text-conversions+    - vector+  source-dirs: library+executables:+  animate-preview:+    dependencies:+    - base >=4.7 && <5+    - animate-preview+    ghc-options:+    - -rtsopts+    - -threaded+    - -with-rtsopts=-N+    main: Main.hs+    source-dirs: executable

+ resource/ProggyClean.ttf view

binary file changed (absent → 41208 bytes)

+ stack.yaml view

@@ -0,0 +1,10 @@+resolver: lts-11.3+packages:+- '.'+extra-deps:+- 'sdl2-mixer-1.1.0'+- 'sdl2-ttf-2.0.2'+- 'animate-0.6.1'+- 'key-state-0.2.0'+flags: {}+extra-package-dbs: []