packages feed

keid-sound-openal (empty) → 0.1.0.0

raw patch · 8 files changed

+328/−0 lines, 8 filesdep +OpenALdep +basedep +geomancysetup-changed

Dependencies added: OpenAL, base, geomancy, keid-core, opusfile, resourcet, rio, unliftio

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for keid-sound-openal++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2021++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 Engine - OpenAL sound system
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keid-sound-openal.cabal view
@@ -0,0 +1,101 @@+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-sound-openal+version:        0.1.0.0+synopsis:       OpenAL sound system for Keid engine.+category:       Game Engine+author:         IC Rainbow+maintainer:     keid@aenor.ru+copyright:      2021 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.Sound.Device+      Engine.Sound.Source+      Resource.Opus+  other-modules:+      Paths_keid_sound_openal+  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:+      OpenAL+    , base >=4.7 && <5+    , geomancy+    , keid-core+    , opusfile+    , resourcet+    , rio >=0.1.12.0+    , unliftio+  default-language: Haskell2010
+ src/Engine/Sound/Device.hs view
@@ -0,0 +1,55 @@+module Engine.Sound.Device+  ( OpenAL.Device+  , allocate+  , create+  , destroy+  ) where++import RIO++import Sound.OpenAL qualified as OpenAL+import UnliftIO.Resource qualified as Resource++allocate+  :: ( Resource.MonadResource m+     , MonadUnliftIO m+     , MonadReader env m+     , HasLogFunc env+     )+  => m (Resource.ReleaseKey, OpenAL.Device)+allocate = do+  soundDevice <- create+  soundDeviceDestroy <- toIO $ destroy soundDevice+  soundDeviceKey <- Resource.register soundDeviceDestroy+  pure (soundDeviceKey, soundDevice)++create+  :: ( MonadReader env m+     , HasLogFunc env+     , MonadUnliftIO m+     )+  => m OpenAL.Device+create = do+  OpenAL.openDevice Nothing >>= \case+    Nothing -> do+      logError "OpenAL: no devices"+      exitFailure+    Just device -> do+      OpenAL.createContext device [] >>= \case+        Nothing -> do+          logError "OpenAL.createContext failed"+          exitFailure+        Just ctx -> do+          OpenAL.currentContext OpenAL.$=! Just ctx+          pure device++destroy+  :: (MonadIO m, MonadReader env m, HasLogFunc env)+  => OpenAL.Device+  -> m ()+destroy device =+  OpenAL.closeDevice device >>= \case+    True ->+      pure ()+    False ->+      logWarn "OpenAL: closeDevice error"
+ src/Engine/Sound/Source.hs view
@@ -0,0 +1,61 @@+module Engine.Sound.Source where++import RIO++import Sound.OpenAL qualified as OpenAL+import UnliftIO.Resource qualified as Resource++class HasSource a where+  getSource :: a -> OpenAL.Source++instance HasSource OpenAL.Source where+  getSource = id++instance HasSource (a, OpenAL.Source) where+  getSource = snd++allocateCollectionWith+  :: ( Resource.MonadResource m+     , Traversable t+     , HasSource o+     )+  => (i -> m o)+  -> t i+  -> m (Resource.ReleaseKey, t o)+allocateCollectionWith action collection = do+  loaded <- traverse action collection++  key <- Resource.register do+    let sources = map getSource $ toList loaded+    OpenAL.stop sources+    for_ sources \source ->+      OpenAL.buffer source OpenAL.$= Nothing+    OpenAL.deleteObjectNames sources++  pure (key, loaded)++{-# INLINE play1 #-}+play1 :: (HasSource a, MonadIO m) => a -> m ()+play1 src = play [src]++{-# INLINE play #-}+play :: (Foldable t, HasSource a, MonadIO m) => t a -> m ()+play = OpenAL.play . map getSource . toList++{-# INLINE stop1 #-}+stop1 :: (HasSource a, MonadIO m) => a -> m ()+stop1 src = stop [src]++{-# INLINE stop #-}+stop :: (Foldable t, HasSource a, MonadIO m) => t a -> m ()+stop = OpenAL.stop . map getSource . toList++{-# INLINE toggle #-}+toggle :: (HasSource a, MonadIO m) => Bool -> a -> m ()+toggle active src =+  if active then+    OpenAL.play srcs+  else+    OpenAL.stop srcs+  where+    srcs = [getSource src]
+ src/Resource/Opus.hs view
@@ -0,0 +1,75 @@+-- {-# LANGUAGE Strict #-}++module Resource.Opus+  ( Config(..)+  , Source+  , load+  ) where++import RIO++import Foreign qualified+import Foreign.C.Types (CFloat(..))+import RIO.ByteString qualified as ByteString+import Sound.OpenAL qualified as OpenAL+import Sound.OpusFile qualified as OpusFile++data Config = Config+  { gain        :: Float+  , loopingMode :: Bool+  , filePath    :: FilePath+  }++type Source = (Double, OpenAL.Source)++load+  :: (MonadIO m, MonadReader env m, HasLogFunc env)+  => OpenAL.Device+  -> Config+  -> m Source+load _device Config{..} = do+  logInfo $ "Loading " <> displayShow filePath+  !pcm <- liftIO do+    Right file <- ByteString.readFile filePath >>= OpusFile.openMemoryBS+    pcmInt16 <- OpusFile.decodeInt16 file+    OpusFile.free file+    pure pcmInt16++  alFormat <-+    case OpusFile.pcmChannels pcm of+      Right OpusFile.Stereo ->+        pure OpenAL.Stereo16+      Right OpusFile.Mono ->+        pure OpenAL.Mono16+      Left n -> do+        logError $ mconcat+          [ "unexpected channels in "+          , displayShow filePath+          , ": "+          , displayShow n+          ]+        exitFailure++  !buffer <- liftIO OpenAL.genObjectName+  liftIO $+    Foreign.withForeignPtr (OpusFile.pcmData pcm) \ptr -> do+      let+        mreg =+          OpenAL.MemoryRegion ptr (fromIntegral $ OpusFile.pcmSize pcm)+      OpenAL.bufferData buffer OpenAL.$=! OpenAL.BufferData mreg alFormat 48000++  !source <- liftIO $ OpenAL.genObjectName+  liftIO do+    OpenAL.buffer source OpenAL.$=! Just buffer+    OpenAL.loopingMode source OpenAL.$=! loopingMode'+    OpenAL.sourceGain source OpenAL.$=! gain'+    OpenAL.rolloffFactor source OpenAL.$=! 0 -- XXX: exempt from distance attenuation++  pure (OpusFile.pcmTime pcm, source)+  where+    loopingMode' =+      if loopingMode then+        OpenAL.Looping+      else+        OpenAL.OneShot+    gain' = CFloat gain