packages feed

keid-frp-banana (empty) → 0.1.0.0

raw patch · 9 files changed

+529/−0 lines, 9 filesdep +basedep +geomancydep +keid-coresetup-changed

Dependencies added: base, geomancy, keid-core, reactive-banana, resourcet, rio, these, vulkan

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for keid-frp-banana++## 0.1.0.0++Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2022++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,1 @@+# Keid FRP - reactive-banana utils
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keid-frp-banana.cabal view
@@ -0,0 +1,102 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           keid-frp-banana+version:        0.1.0.0+synopsis:       Reactive Banana integration for Keid engine.+category:       Game Engine+author:         IC Rainbow+maintainer:     keid@aenor.ru+copyright:      2022 IC Rainbow+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://gitlab.com/keid/engine++library+  exposed-modules:+      Engine.ReactiveBanana+      Engine.ReactiveBanana.Course+      Engine.ReactiveBanana.Stateful+      Engine.ReactiveBanana.Window+  other-modules:+      Paths_keid_frp_banana+  hs-source-dirs:+      src+  default-extensions:+      NoImplicitPrelude+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstrainedClassMethods+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      EmptyCase+      EmptyDataDeriving+      ExistentialQuantification+      ExplicitForAll+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      HexFloatLiterals+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      NamedFieldPuns+      NamedWildCards+      NumDecimals+      NumericUnderscores+      OverloadedStrings+      PatternSynonyms+      PostfixOperators+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , geomancy >=0.2.4.0+    , keid-core >=0.1.6.1+    , reactive-banana >=1.3.0.0+    , resourcet+    , rio >=0.1.12.0+    , these+    , vulkan+  default-language: Haskell2010
+ src/Engine/ReactiveBanana.hs view
@@ -0,0 +1,165 @@+module Engine.ReactiveBanana+  ( eventHandler+  , timer+  , observe++  , allocateActuated+  , allocatePaused++  , pushWorkerInput+  , pushWorkerInputJust++  , pushWorkerOutput+  , pushWorkerOutputJust++  , reactimateDebugShow++  , debounce+  ) where++import RIO++import Engine.Worker qualified as Worker+import GHC.Stack (withFrozenCallStack)+import Reactive.Banana qualified as RB+import Reactive.Banana.Frameworks qualified as RBF+import Resource.Region qualified as Region+import UnliftIO.Resource (ResourceT)+import UnliftIO.Resource qualified as Resource++eventHandler+  :: (Resource.MonadResource m, MonadIO io)+  => ((a -> io ()) -> m Resource.ReleaseKey)+  -> ResourceT m (RBF.MomentIO (RB.Event a))+eventHandler action = do+  (addHandler, fire) <- liftIO RBF.newAddHandler+  Region.local_ $ action (liftIO . fire)+  pure $ RBF.fromAddHandler addHandler++timer+  :: (MonadUnliftIO m)+  => Int+  -> ResourceT m (RBF.MomentIO (RB.Event Double))+timer delayMS = do+  (addHandler, fire) <- liftIO RBF.newAddHandler+  ticker <- async do+    begin <- getMonotonicTime+    threadDelay delayMS+    forever do+      before <- getMonotonicTime+      liftIO $ fire before+      after <- getMonotonicTime+      let+        tickNum       = (after - begin) * 1e6 / fromIntegral delayMS :: Double+        intTick       = truncate tickNum :: Integer+        driftTicks    = tickNum - fromInteger intTick :: Double+        driftMS       = driftTicks * fromIntegral delayMS :: Double+        adjustedDelay = max 0 $ delayMS - ceiling driftMS :: Int+      -- when (driftTicks > 0.01) $+      --   -- traceShowM driftTicks+      --   traceShowM (delayMS, (tickNum, intTick, driftTicks), driftMS, adjustedDelay)+      threadDelay adjustedDelay++  Region.attachAsync ticker+  pure $ RBF.fromAddHandler addHandler++observe+  :: (MonadUnliftIO m)+  => Worker.Var a+  -> ResourceT m (RBF.MomentIO (RB.Event a))+observe var = do+  (addHandler, fire) <- liftIO RBF.newAddHandler++  initial <- readTVarIO var++  tracker <- async $+    go fire (Worker.vVersion initial)+  Region.attachAsync tracker++  liftIO $ fire (Worker.vData initial) -- XXX: the network isn't compiled yet!+  pure $ RBF.fromAddHandler addHandler+  where+    go fire oldVersion = do+      Worker.Versioned{..} <- atomically do+        next <- readTVar var+        if Worker.vVersion next > oldVersion then+          pure next+        else+          retrySTM+      liftIO $ fire vData+      go fire vVersion++allocateActuated+  :: MonadUnliftIO m+  => (UnliftIO m -> RB.Event () -> RBF.MomentIO ())+  -> ResourceT m RBF.EventNetwork+allocateActuated builder = do+  (ah, fire) <- liftIO RBF.newAddHandler++  network <- allocatePaused \unlift -> do+    started <- RBF.fromAddHandler ah+    builder unlift started++  liftIO do+    RBF.actuate network+    fire ()+    pure network++allocatePaused+  :: MonadUnliftIO m+  => (UnliftIO m -> RBF.MomentIO ())+  -> ResourceT m RBF.EventNetwork+allocatePaused builder = do+  unlift <- lift askUnliftIO+  fmap snd $+    Resource.allocate+      (RBF.compile $ builder unlift)+      RBF.pause++pushWorkerInput+  :: Worker.HasInput var+  => var+  -> RB.Event (Worker.GetInput var)+  -> RBF.MomentIO ()+pushWorkerInput p = RBF.reactimate . fmap (Worker.pushInput p . const)++pushWorkerInputJust+  :: Worker.HasInput var+  => var+  -> RB.Event (Maybe (Worker.GetInput var))+  -> RBF.MomentIO ()+pushWorkerInputJust p = RBF.reactimate . fmap (traverse_ $ Worker.pushInput p . const)++pushWorkerOutput+  :: Worker.HasOutput var+  => var+  -> RB.Event (Worker.GetOutput var)+  -> RBF.MomentIO ()+pushWorkerOutput p = RBF.reactimate . fmap (Worker.pushOutput p . const)++pushWorkerOutputJust+  :: Worker.HasOutput var+  => var+  -> RB.Event (Maybe (Worker.GetOutput var))+  -> RBF.MomentIO ()+pushWorkerOutputJust p = RBF.reactimate . fmap (traverse_ $ Worker.pushOutput p . const)++reactimateDebugShow+  :: (Show a, MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)+  => (m () -> IO ())+  -> RB.Event a+  -> RBF.MomentIO ()+reactimateDebugShow unlift =+  RBF.reactimate . fmap (unlift . withFrozenCallStack logDebug . displayShow)++debounce :: Eq a => a -> RB.Event a -> RBF.MomentIO (RB.Event a)+debounce initial spamUpdates = do+  (e, fire) <- RBF.newEvent+  oldVar <- newIORef initial+  RBF.reactimate $+    spamUpdates <&> \new -> do+      changed <- atomicModifyIORef' oldVar \old ->+        (new, old /= new)+      when changed $+        fire new+  pure e
+ src/Engine/ReactiveBanana/Course.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE RecursiveDo #-}++module Engine.ReactiveBanana.Course+  ( Course(..)++  , setup++  , whenIdle+  , whenActive+  , whenFinished++  , isIdle+  , isActive+  , isFinished+  , when+  , unless+  ) where++import RIO hiding (when, unless)++import Data.Maybe (fromJust)+import Data.These (These(..))+import Reactive.Banana qualified as RB+import Reactive.Banana.Frameworks qualified as RBF++data Course a+  = Idle+  | Active a+  | Finished+  deriving (Eq, Ord, Show, Functor)++setup+  :: RB.Event a+  -> RB.Event (a -> Either final a)+  -> RBF.MomentIO (RB.Event a, RB.Event final, RB.Behavior (Course a))+setup triggerE stepE = mdo+  (e, b) <- RB.mapAccum Idle $+    fmap dispatch $+      RB.merge triggerE (whenActive b stepE)++  (activeE, fireActive) <- RBF.newEvent+  RBF.reactimate $ (e RB.@> b) <&> \case+    Active a ->+      fireActive a+    _ ->+      pure ()++  finishedE <- RB.once $+    fmap fromJust $ RB.filterE isJust e+  pure (activeE, finishedE, b)+  where+    dispatch = \case+      This initial -> \case+        Idle ->+          (Nothing, Active initial)+        Active{} ->+          error "trigger not filtered when active"+        Finished ->+          error "trigger not filtered when finished"++      That step -> \case+        Idle ->+          error "tick not filtered when idle"+        Active current ->+          case step current of+            Left done ->+              (Just done, Finished)+            Right next ->+              (Nothing, Active next)+        Finished ->+          error "tick not filtered when finished"++      These{} ->+        error "tick happened on top of trigger"++when :: (Course a -> Bool) -> RB.Behavior (Course a) -> RB.Event e -> RB.Event e+when pred course =+  RB.filterApply (course <&> const . pred)++unless :: (Course a -> Bool) -> RB.Behavior (Course a) -> RB.Event e -> RB.Event e+unless pred course =+  RB.filterApply (course <&> const . not . pred)++whenIdle :: RB.Behavior (Course a) -> RB.Event e -> RB.Event e+whenIdle = when isIdle++whenActive :: RB.Behavior (Course a) -> RB.Event e -> RB.Event e+whenActive = when isActive++whenFinished :: RB.Behavior (Course a) -> RB.Event e -> RB.Event e+whenFinished = when isFinished++isIdle :: Course a -> Bool+isIdle = \case+  Idle -> True+  _    -> False++isActive :: Course a -> Bool+isActive = \case+  Active{} -> True+  _        -> False++isFinished :: Course a -> Bool+isFinished = \case+  Finished -> True+  _        -> False
+ src/Engine/ReactiveBanana/Stateful.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE RecursiveDo #-}++module Engine.ReactiveBanana.Stateful+  ( setup+  , runWorldWith+  , Thaw+  ) where++import Prelude+import Control.Monad.ST (ST)+import Reactive.Banana qualified as RB++setup+  :: RB.MonadMoment m+  => m acc+  -> (a -> acc -> (x, acc))+  -> RB.Event a+  -> m (RB.Event x, RB.Behavior acc)+setup initialWorld action triggerE = mdo+  initial <- initialWorld+  RB.mapAccum initial $+    fmap action triggerE++type family Thaw world s++runWorldWith+  :: (world -> ST s (Thaw world s))+  -> (Thaw world s -> ST s world)+  -> world+  -> (Thaw world s -> ST s update)+  -> ST s (update, world)+runWorldWith t f old action = do+  st <- t old+  res <- action st+  new <- f st+  pure (res, new)
+ src/Engine/ReactiveBanana/Window.hs view
@@ -0,0 +1,82 @@+module Engine.ReactiveBanana.Window where++import RIO++import Engine.Types (StageRIO)+import Engine.Types qualified as Engine+import Engine.UI.Layout qualified as Layout+import Engine.Window.MouseButton qualified as MouseButton+import Engine.Worker qualified as Worker+import Geomancy (Vec2, vec2, (^/))+import GHC.Float (double2Float)+import Reactive.Banana ((<@>), (<@>))+import Reactive.Banana qualified as RB+import Reactive.Banana.Frameworks qualified as RBF+import Vulkan.Core10 qualified as Vk++setupScreenBox+  :: (forall a. StageRIO env a -> RBF.MomentIO a)+  -> RBF.MomentIO (RB.Behavior Layout.Box)+setupScreenBox unlift = do+  screenExtent <- unlift Engine.askScreenVar >>=+    RBF.fromPoll . Worker.getOutputData++  let+    screenSize =+      screenExtent <&>+        \Vk.Extent2D{width, height} ->+          vec2+            (fromIntegral width)+            (fromIntegral height)++    screenBox =+      screenSize <&> \size ->+        Layout.Box+          { boxPosition = 0 -- XXX: since Camera.spawnOrthoPixelsCentered+          , boxSize     = size+          }++  pure screenBox++setupCursorPos+  :: RB.MonadMoment m+  => m (RB.Event (Double, Double))+  -> RB.Behavior Layout.Box+  -> m (RB.Event Vec2, RB.Behavior Vec2)+setupCursorPos fromCursorPos screenBox = do+  cursorPosRawE <- fromCursorPos+  let cursorPosE = convertPos <$> screenBox <@> cursorPosRawE++  cursorPos <- RB.stepper+    (1/0) -- XXX: prevent accidental flash of hover at (0, 0)+    cursorPosE+  pure (cursorPosE, cursorPos)+  where+    convertPos Layout.Box{boxSize} (cx, cy) =+      -- XXX: since Camera.spawnOrthoPixelsCentered+      vec2 (double2Float cx) (double2Float cy) -+      boxSize ^/ 2++setupMouseClicks+  :: RBF.MomentIO (RB.Event (MouseButton.ModifierKeys, MouseButton.MouseButtonState, MouseButton.MouseButton))+  -> RB.Behavior cursor+  -> RBF.MomentIO (MouseButton.Collection (RB.Event (MouseButton.ModifierKeys, cursor)))+setupMouseClicks fromMouseButton cursorPos = do+  -- imguiCaptureMouse <- RBF.fromPoll ImGui.wantCaptureMouse++  -- mouseButtonE <- RB.whenE (fmap not imguiCaptureMouse) <$> fromMouseButton+  mouseButtonE <- fromMouseButton++  -- XXX: Set up cursor event fusion, driven by mouseButtonE+  mouseButtons' <- sequenceA @MouseButton.Collection $ pure RBF.newEvent++  let+    dispatchButtons pos (mods, state, mb) =+      MouseButton.whenPressed state $+        -- XXX: Use one event handler to drive multiple derived events+        snd (MouseButton.atGlfw mouseButtons' mb) (mods, pos)++  RBF.reactimate $+    dispatchButtons <$> cursorPos <@> mouseButtonE++  pure $ fmap fst mouseButtons'