diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# dahdit-audio + +Audio file parsing/printing with dahdit + +Supports + +* RIFF +* WAVE +* AIFF +* SF2 diff --git a/dahdit-audio.cabal b/dahdit-audio.cabal new file mode 100644 --- /dev/null +++ b/dahdit-audio.cabal @@ -0,0 +1,157 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.0. +-- +-- see: https://github.com/sol/hpack + +name: dahdit-audio +version: 0.8.0 +synopsis: Audio file parsing/printing with dahdit +description: Please see the README on GitHub at +homepage: https://github.com/ejconlon/dahdit#readme +bug-reports: https://github.com/ejconlon/dahdit/issues +author: Eric Conlon +maintainer: ejconlon@gmail.com +copyright: (c) 2023 Eric Conlon +license: BSD3 +build-type: Simple +tested-with: + GHC == 9.8.4 +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/ejconlon/dahdit + +library + exposed-modules: + Dahdit.Audio.Aiff + Dahdit.Audio.Common + Dahdit.Audio.Convert + Dahdit.Audio.Dsp + Dahdit.Audio.Quiet + Dahdit.Audio.Riff + Dahdit.Audio.Sfont + Dahdit.Audio.Wav + Dahdit.Audio.Wav.Simple + other-modules: + Paths_dahdit_audio + hs-source-dirs: + src + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveFunctor + DeriveFoldable + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + KindSignatures + MultiParamTypeClasses + MultiWayIf + Rank2Types + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + TypeFamilies + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds + build-depends: + aeson ==2.2.* + , aeson-casing ==0.2.* + , aeson-pretty ==0.8.* + , aeson-via ==0.2.* + , base >=4.12 && <5 + , bytestring ==0.12.* + , containers ==0.6.* + , dahdit ==0.8.* + , data-default ==0.7.* + , data-sword ==0.2.* + , digest >=0.0.1 && <0.0.3 + , directory ==1.3.* + , filepath ==1.4.* + , ghc-typelits-knownnat ==0.7.* + , microlens ==0.4.* + , mtl >=2.2 && <2.4 + , optparse-applicative >=0.16 && <0.19 + , pathwalk ==0.3.* + , prettyprinter ==1.7.* + , primitive ==0.9.* + , regex-tdfa ==1.3.* + , text ==2.1.* + , transformers >=0.5 && <0.7 + default-language: GHC2021 + +test-suite dahdit-audio-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_dahdit_audio + hs-source-dirs: + test + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveFunctor + DeriveFoldable + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + KindSignatures + MultiParamTypeClasses + MultiWayIf + Rank2Types + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + TypeFamilies + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson ==2.2.* + , aeson-casing ==0.2.* + , aeson-pretty ==0.8.* + , aeson-via ==0.2.* + , base >=4.12 && <5 + , bytestring ==0.12.* + , containers ==0.6.* + , dahdit ==0.8.* + , dahdit-audio + , data-default ==0.7.* + , data-sword ==0.2.* + , daytripper + , digest >=0.0.1 && <0.0.3 + , directory ==1.3.* + , filepath ==1.4.* + , ghc-typelits-knownnat ==0.7.* + , microlens ==0.4.* + , mtl >=2.2 && <2.4 + , optparse-applicative >=0.16 && <0.19 + , pathwalk ==0.3.* + , prettyprinter ==1.7.* + , primitive ==0.9.* + , regex-tdfa ==1.3.* + , tasty ==1.5.* + , tasty-hunit ==0.10.* + , text ==2.1.* + , transformers >=0.5 && <0.7 + default-language: GHC2021 diff --git a/src/Dahdit/Audio/Aiff.hs b/src/Dahdit/Audio/Aiff.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Aiff.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoStarIsType #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +module Dahdit.Audio.Aiff + ( PascalString (..) + , Chunk (..) + , KnownChunk (..) + , Variant (..) + , AiffCommonBody (..) + , AiffCommonChunk + , AiffDataBody (..) + , AiffDataChunk + , AiffChunk (..) + , Aiff (..) + , lookupAiffChunk + , lookupAiffCommonChunk + , lookupAiffDataChunk + , aiffToPcmContainer + , aiffGatherMarkers + ) +where + +import Control.Monad (unless) +import Dahdit + ( Binary (..) + , ByteArray + , ByteCount (..) + , Get + , Put + , ShortByteString + , StaticByteSized (..) + , StaticBytes (..) + , ViaGeneric (..) + , ViaStaticGeneric (..) + , Word16BE + , Word32BE (..) + , byteSizeFoldable + , getByteString + , getExact + , getLookAhead + , getRemainingByteArray + , getRemainingSeq + , getSeq + , getSkip + , getWord16BE + , getWord8 + , putByteArray + , putByteString + , putSeq + , putWord16BE + , putWord8 + ) +import Dahdit.Audio.Common + ( ChunkHeaderSize + , ConvertErr + , CountSize + , KnownLabel (..) + , Label + , LabelSize + , PadCount + , SimpleMarker (..) + , UnparsedBody + , chunkHeaderSize + , countSize + , dedupeSimpleMarkers + , getChunkSizeBE + , getExpectLabel + , guardChunk + , labelSize + , padCount + , putChunkSizeBE + ) +import Dahdit.Audio.Dsp (PcmContainer (PcmContainer), PcmMeta (PcmMeta)) +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Short qualified as BSS +import Data.Default (Default (..)) +import Data.Foldable (toList) +import Data.Maybe (fromMaybe) +import Data.Primitive.ByteArray (byteArrayFromListN, indexByteArray, sizeofByteArray) +import Data.Proxy (Proxy (..)) +import Data.Sequence (Seq (..)) +import Data.Sequence qualified as Seq +import Data.Word (Word8) +import GHC.Generics (Generic) +import GHC.TypeLits (type (*), type (+)) + +-- AIFF-C file parsing according to +-- http://www-mmsp.ece.mcgill.ca/Documents/AudioFormats/AIFF/AIFF.html +-- We only bother to support "sowt" compression (little endian samples) + +-- AIFF shares a similar 4-byte label + size + payload structure with RIFF +-- We could use a lot of the same structures to read the file... If they were +-- big-endian. + +labelForm, labelAifc, labelAiff, labelComm, labelSsnd, labelFver, labelAnno, labelMark, labelSowt :: Label +labelForm = "FORM" +labelAifc = "AIFC" +labelAiff = "AIFF" +labelComm = "COMM" +labelSsnd = "SSND" +labelFver = "FVER" +labelAnno = "ANNO" +labelMark = "MARK" +labelSowt = "sowt" + +data Chunk a = Chunk + { chunkLabel :: !Label + , chunkBody :: !a + } + deriving stock (Eq, Show) + +chunkUnpaddedByteSize :: (Binary a) => Chunk a -> ByteCount +chunkUnpaddedByteSize (Chunk _ body) = byteSize body + +instance (StaticByteSized a) => StaticByteSized (Chunk a) where + type StaticSize (Chunk a) = PadCount (ChunkHeaderSize + StaticSize a) + +instance (Binary a) => Binary (Chunk a) where + byteSize c = padCount (chunkHeaderSize + chunkUnpaddedByteSize c) + get = do + lab <- get + usz <- getChunkSizeBE + body <- getExact usz get + unless (even usz) (getSkip 1) + pure $! Chunk lab body + put c@(Chunk lab body) = do + put lab + let !usz = chunkUnpaddedByteSize c + putChunkSizeBE usz + put body + unless (even usz) (putWord8 0) + +newtype KnownChunk a = KnownChunk + { knownChunkBody :: a + } + deriving stock (Show) + deriving newtype (Eq, Default) + +knownChunkUnpaddedByteSize :: (Binary a) => KnownChunk a -> ByteCount +knownChunkUnpaddedByteSize (KnownChunk body) = byteSize body + +instance (StaticByteSized a) => StaticByteSized (KnownChunk a) where + type StaticSize (KnownChunk a) = PadCount (ChunkHeaderSize + StaticSize a) + +instance (Binary a, KnownLabel a) => Binary (KnownChunk a) where + byteSize kc = padCount (chunkHeaderSize + knownChunkUnpaddedByteSize kc) + get = do + getExpectLabel (knownLabel (Proxy :: Proxy a)) + usz <- getChunkSizeBE + body <- getExact usz get + unless (even usz) (getSkip 1) + pure $! KnownChunk body + put kc@(KnownChunk body) = do + put (knownLabel (Proxy :: Proxy a)) + let !usz = knownChunkUnpaddedByteSize kc + putChunkSizeBE usz + put body + unless (even usz) (putWord8 0) + +-- | A "Pascal-style string" with a leading byte count and optional +-- trailing padding byte to make total length even. +newtype PascalString = PascalString {unPascalString :: ShortByteString} + deriving stock (Show) + deriving newtype (Eq) + +instance Default PascalString where + def = PascalString BSS.empty + +instance Binary PascalString where + byteSize (PascalString sbs) = padCount (ByteCount (BSS.length sbs + 1)) + get = do + usz <- fmap fromIntegral getWord8 + sbs <- getByteString usz + unless (odd usz) (getSkip 1) + pure $! PascalString sbs + put (PascalString sbs) = do + let !usz = fromIntegral (BSS.length sbs) + putWord8 usz + putByteString sbs + unless (odd usz) (putWord8 0) + +notCompressed :: PascalString +notCompressed = PascalString (BSS.toShort (BSC.pack "not compressed")) + +-- | "80 bit IEEE Standard 754 floating point number" +newtype ExtendedFloat = ExtendedFloat {unExtendedFloat :: StaticBytes 10} + deriving stock (Show) + deriving newtype (Eq, Default, StaticByteSized, Binary) + +data AiffCommonBody = AiffCommonBody + { aceNumChannels :: !Word16BE + , aceNumSampleFrames :: !Word32BE + , aceSampleSize :: !Word16BE + , aceSampleRate :: !ExtendedFloat + , aceCompressionType :: !Label + , aceCompressionName :: !PascalString + } + deriving stock (Eq, Show, Generic) + deriving (Binary) via (ViaGeneric AiffCommonBody) + +instance KnownLabel AiffCommonBody where + knownLabel _ = labelComm + +type AiffCommonChunk = KnownChunk AiffCommonBody + +data AiffCommonBodyOld = AiffCommonBodyOld + { aceoNumChannels :: !Word16BE + , aceoNumSampleFrames :: !Word32BE + , aceoSampleSize :: !Word16BE + , aceoSampleRate :: !ExtendedFloat + } + deriving stock (Eq, Show, Generic) + deriving (Binary) via (ViaStaticGeneric AiffCommonBodyOld) + +instance KnownLabel AiffCommonBodyOld where + knownLabel _ = labelComm + +type AiffCommonChunkOld = KnownChunk AiffCommonBodyOld + +oldToNewCommonChunk :: KnownChunk AiffCommonBodyOld -> KnownChunk AiffCommonBody +oldToNewCommonChunk (KnownChunk (AiffCommonBodyOld x y z w)) = KnownChunk (AiffCommonBody x y z w labelSowt notCompressed) + +newToOldCommonChunk :: KnownChunk AiffCommonBody -> KnownChunk AiffCommonBodyOld +newToOldCommonChunk (KnownChunk (AiffCommonBody x y z w _ _)) = KnownChunk (AiffCommonBodyOld x y z w) + +getCommonChunk :: Variant -> Get AiffCommonChunk +getCommonChunk = \case + VariantAiff -> fmap oldToNewCommonChunk get + VariantAifc -> get + +putCommonChunk :: Variant -> AiffCommonChunk -> Put +putCommonChunk = \case + VariantAiff -> put . newToOldCommonChunk + VariantAifc -> put + +data AiffDataBody = AiffDataBody + { adbOffset :: !Word32BE + , adbBlockSize :: !Word32BE + , adbSoundData :: !ByteArray + } + deriving stock (Eq, Show, Generic) + +instance Binary AiffDataBody where + byteSize (AiffDataBody _ _ arr) = 8 + fromIntegral (sizeofByteArray arr) + get = do + adbOffset <- get + unless (adbOffset == 0) (fail "need zero offset") + adbBlockSize <- get + adbSoundData <- getRemainingByteArray + pure $! AiffDataBody {..} + put (AiffDataBody {..}) = do + put adbOffset + put adbBlockSize + putByteArray adbSoundData + +instance KnownLabel AiffDataBody where + knownLabel _ = labelSsnd + +type AiffDataChunk = KnownChunk AiffDataBody + +type AiffVersionChunk = Chunk UnparsedBody + +type AiffAnnoChunk = Chunk UnparsedBody + +data AiffMark = AiffMark + { amId :: !Word16BE + , amPosition :: !Word32BE + , amName :: !PascalString + } + deriving stock (Eq, Show, Generic) + deriving (Binary) via (ViaGeneric AiffMark) + +newtype AiffMarkBody = AiffMarkBody + { ambMarkers :: Seq AiffMark + } + deriving stock (Show) + deriving newtype (Eq) + +instance Binary AiffMarkBody where + byteSize (AiffMarkBody marks) = 2 + byteSizeFoldable marks + get = do + ec <- fmap fromIntegral getWord16BE + marks <- getSeq ec get + pure $! AiffMarkBody marks + put (AiffMarkBody marks) = do + putWord16BE (fromIntegral (Seq.length marks)) + putSeq put marks + +instance KnownLabel AiffMarkBody where + knownLabel _ = labelMark + +type AiffMarkChunk = KnownChunk AiffMarkBody + +type AiffUnparsedChunk = Chunk UnparsedBody + +data AiffChunk + = AiffChunkCommon !AiffCommonChunk + | AiffChunkData !AiffDataChunk + | AiffChunkVersion !AiffVersionChunk + | AiffChunkAnno !AiffAnnoChunk + | AiffChunkMark !AiffMarkChunk + | AiffChunkUnparsed !AiffUnparsedChunk + deriving stock (Eq, Show, Generic) + +getChunk :: Variant -> Get AiffChunk +getChunk variant = do + label <- getLookAhead get + if + | label == labelComm -> fmap AiffChunkCommon (getCommonChunk variant) + | label == labelSsnd -> fmap AiffChunkData get + | label == labelFver -> fmap AiffChunkVersion get + | label == labelAnno -> fmap AiffChunkAnno get + | label == labelMark -> fmap AiffChunkMark get + | otherwise -> fmap AiffChunkUnparsed get + +putChunk :: Variant -> AiffChunk -> Put +putChunk variant = \case + AiffChunkCommon x -> putCommonChunk variant x + AiffChunkData x -> put x + AiffChunkVersion x -> put x + AiffChunkAnno x -> put x + AiffChunkMark x -> put x + AiffChunkUnparsed x -> put x + +instance Binary AiffChunk where + byteSize = \case + AiffChunkCommon x -> byteSize x + AiffChunkData x -> byteSize x + AiffChunkVersion x -> byteSize x + AiffChunkAnno x -> byteSize x + AiffChunkMark x -> byteSize x + AiffChunkUnparsed x -> byteSize x + get = getChunk VariantAifc + put = putChunk VariantAifc + +data Variant = VariantAiff | VariantAifc + deriving stock (Eq, Show) + +data AiffHeader = AiffHeader + { ahVariant :: !Variant + , ahRemainingSize :: ByteCount + } + deriving stock (Eq, Show, Generic) + +type AiffHeaderSize = 2 * LabelSize + CountSize + +aiffHeaderSize :: ByteCount +aiffHeaderSize = 2 * labelSize + countSize + +instance StaticByteSized AiffHeader where + type StaticSize AiffHeader = AiffHeaderSize + staticByteSize _ = aiffHeaderSize + +instance Binary AiffHeader where + get = do + getExpectLabel labelForm + sz <- getChunkSizeBE + label <- get @Label + variant <- + if + | label == labelAiff -> pure VariantAiff + | label == labelAifc -> pure VariantAifc + | otherwise -> fail ("Expected label AIFC or AIFF in header but got: " ++ show (unStaticBytes label)) + pure $! AiffHeader variant (sz - labelSize) + put (AiffHeader variant remSz) = do + put labelForm + putChunkSizeBE (remSz + labelSize) + put $ case variant of + VariantAiff -> labelAiff + VariantAifc -> labelAifc + +data Aiff = Aiff + { aiffVariant :: !Variant + , aiffChunks :: !(Seq AiffChunk) + } + deriving stock (Eq, Show) + +instance Binary Aiff where + byteSize (Aiff _ chunks) = aiffHeaderSize + byteSizeFoldable chunks + get = do + AiffHeader variant remSz <- get + chunks <- getExact remSz (getRemainingSeq (getChunk variant)) + let !chunks' = swapDataEndian variant chunks + pure $! Aiff variant chunks' + put (Aiff variant chunks) = do + let !chunks' = swapDataEndian variant chunks + let !remSz = byteSizeFoldable chunks' + put (AiffHeader variant remSz) + putSeq (putChunk variant) chunks' + +swapDataEndian :: Variant -> Seq AiffChunk -> Seq AiffChunk +swapDataEndian variant chunks = + case variant of + VariantAifc -> chunks + VariantAiff -> fromMaybe chunks $ do + let aiff = Aiff variant chunks + KnownChunk comBody <- lookupAiffCommonChunk aiff + KnownChunk (AiffDataBody x y arr) <- lookupAiffDataChunk aiff + let arr' = swapArrayEndian (fromIntegral (aceSampleSize comBody)) arr + let datChunk' = KnownChunk (AiffDataBody x y arr') + Just $! flip fmap chunks $ \c -> + case c of + AiffChunkData _ -> AiffChunkData datChunk' + _ -> c + +swappedByteArray2 :: ByteArray -> [Word8] +swappedByteArray2 arr = go 0 Empty + where + sz = sizeofByteArray arr + go !i !acc = + if i == sz + then toList acc + else go (i + 2) (acc :|> indexByteArray arr (i + 1) :|> indexByteArray arr i) + +swappedByteArray3 :: ByteArray -> [Word8] +swappedByteArray3 arr = go 0 Empty + where + sz = sizeofByteArray arr + go !i !acc = + if i == sz + then toList acc + else go (i + 3) (acc :|> indexByteArray arr (i + 2) :|> indexByteArray arr (i + 1) :|> indexByteArray arr i) + +swapArrayEndian :: Int -> ByteArray -> ByteArray +swapArrayEndian bitDepth arr = + if + | bitDepth == 8 -> arr + | bitDepth == 16 -> byteArrayFromListN (sizeofByteArray arr) (swappedByteArray2 arr) + | bitDepth == 24 -> byteArrayFromListN (sizeofByteArray arr) (swappedByteArray3 arr) + | otherwise -> error ("Unsupported endian swap depth: " ++ show bitDepth) + +lookupAiffChunk :: (AiffChunk -> Bool) -> Aiff -> Maybe AiffChunk +lookupAiffChunk p (Aiff _ chunks) = fmap (Seq.index chunks) (Seq.findIndexL p chunks) + +lookupAiffCommonChunk :: Aiff -> Maybe AiffCommonChunk +lookupAiffCommonChunk w = + case lookupAiffChunk (\case AiffChunkCommon _ -> True; _ -> False) w of + Just (AiffChunkCommon x) -> Just x + _ -> Nothing + +lookupAiffDataChunk :: Aiff -> Maybe AiffDataChunk +lookupAiffDataChunk w = + case lookupAiffChunk (\case AiffChunkData _ -> True; _ -> False) w of + Just (AiffChunkData x) -> Just x + _ -> Nothing + +lookupAiffMarkChunk :: Aiff -> Maybe AiffMarkChunk +lookupAiffMarkChunk w = + case lookupAiffChunk (\case AiffChunkMark _ -> True; _ -> False) w of + Just (AiffChunkMark x) -> Just x + _ -> Nothing + +-- NOTE: Taking sr as a param here so we don't have to interpret extended fp +aiffToPcmContainer :: Int -> Aiff -> Either ConvertErr PcmContainer +aiffToPcmContainer sr aiff = do + KnownChunk commBody <- guardChunk "common" (lookupAiffCommonChunk aiff) + KnownChunk dataBody <- guardChunk "data" (lookupAiffDataChunk aiff) + let !nc = fromIntegral (aceNumChannels commBody) + !ns = fromIntegral (aceNumSampleFrames commBody) + !bps = fromIntegral (aceSampleSize commBody) + !meta = PcmMeta nc ns bps sr + !arr = adbSoundData dataBody + pure $! PcmContainer meta arr + +aiffGatherMarkers :: Aiff -> Seq SimpleMarker +aiffGatherMarkers aiff = + case lookupAiffMarkChunk aiff of + Nothing -> Empty + Just (KnownChunk (AiffMarkBody marks)) -> + dedupeSimpleMarkers (fmap (\am -> SimpleMarker (unPascalString (amName am)) (unWord32BE (amPosition am))) marks) diff --git a/src/Dahdit/Audio/Common.hs b/src/Dahdit/Audio/Common.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Common.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dahdit.Audio.Common + ( rethrow + , LabelSize + , CountSize + , Label + , labelSize + , countSize + , getExpectLabel + , getChunkSizeLE + , expectChunkSizeLE + , putChunkSizeLE + , getChunkSizeBE + , expectChunkSizeBE + , putChunkSizeBE + , ChunkHeaderSize + , chunkHeaderSize + , KnownLabel (..) + , UnparsedBody (..) + , PadCount + , padCount + , SimpleMarker (..) + , dedupeSimpleMarkers + , ConvertErr (..) + , guardBps + , guardChunk + , LoopMarks (..) + , LoopMarkNames + , LoopMarkPoints + , defaultLoopMarkNames + , defineLoopMarks + , findMark + , findLoopMarks + , recallLoopMarkNames + , defaultNoteNumber + , adjustMarker + , adjustLoopPoints + ) +where + +import Control.Exception (Exception, throwIO) +import Control.Monad (unless) +import Dahdit + ( Binary (..) + , ByteCount + , Get + , Put + , StaticBytes + , Word32BE + , Word32LE + , getExpect + , getRemainingString + , putByteString + ) +import Dahdit.Audio.Dsp (DspErr) +import Data.ByteString.Short (ShortByteString) +import Data.ByteString.Short qualified as BSS +import Data.Proxy (Proxy (..)) +import Data.Sequence (Seq (..)) +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +import Data.Word (Word32) +import GHC.TypeLits (Mod, Nat, type (+)) + +rethrow :: (Exception e) => Either e a -> IO a +rethrow = either throwIO pure + +type LabelSize = 4 :: Nat + +type CountSize = 4 :: Nat + +type Label = StaticBytes LabelSize + +labelSize, countSize :: ByteCount +labelSize = 4 +countSize = 4 + +getExpectLabel :: Label -> Get () +getExpectLabel = getExpect "label" get + +getChunkSizeLE :: Get ByteCount +getChunkSizeLE = fmap fromIntegral (get @Word32LE) + +expectChunkSizeLE :: ByteCount -> Get () +expectChunkSizeLE = getExpect "chunk size" getChunkSizeLE + +putChunkSizeLE :: ByteCount -> Put +putChunkSizeLE = put @Word32LE . fromIntegral + +getChunkSizeBE :: Get ByteCount +getChunkSizeBE = fmap fromIntegral (get @Word32BE) + +expectChunkSizeBE :: ByteCount -> Get () +expectChunkSizeBE = getExpect "chunk size" getChunkSizeBE + +putChunkSizeBE :: ByteCount -> Put +putChunkSizeBE = put @Word32BE . fromIntegral + +type ChunkHeaderSize = 8 :: Nat + +chunkHeaderSize :: ByteCount +chunkHeaderSize = 8 + +class KnownLabel a where + knownLabel :: Proxy a -> Label + +newtype UnparsedBody = UnparsedBody + { ubContents :: ShortByteString + } + deriving stock (Show) + deriving newtype (Eq) + +instance Binary UnparsedBody where + byteSize (UnparsedBody bs) = fromIntegral (BSS.length bs) + get = fmap UnparsedBody getRemainingString + put (UnparsedBody bs) = putByteString bs + +type PadCount (n :: Nat) = n + Mod n 2 + +padCount :: ByteCount -> ByteCount +padCount bc = if even bc then bc else bc + 1 + +data SimpleMarker = SimpleMarker + { smName :: !ShortByteString + -- ^ name of the cue point + , smPosition :: !Word32 + -- ^ position in SAMPLES not bytes or elements + } + deriving stock (Eq, Show) + +ordNubBy :: (Ord b) => (a -> b) -> Seq a -> Seq a +ordNubBy f = go Set.empty Seq.empty + where + go !accSet !accSeq = \case + Empty -> accSeq + x :<| xs -> + let !y = f x + in if Set.member y accSet + then go accSet accSeq xs + else go (Set.insert y accSet) (accSeq :|> x) xs + +-- | Sort, keeping the first of any given name +dedupeSimpleMarkers :: Seq SimpleMarker -> Seq SimpleMarker +dedupeSimpleMarkers = ordNubBy smName . Seq.sortOn smPosition + +data ConvertErr + = ConvertErrMissingChunk !String + | ConvertErrDsp !DspErr + | ConvertErrBadBps !Int + | ConvertErrMissingMark !ShortByteString + | ConvertErrNoLoopMarks + deriving stock (Eq, Show) + +instance Exception ConvertErr + +guardBps :: Int -> Int -> Either ConvertErr () +guardBps needBps haveBps = unless (needBps == haveBps) (Left (ConvertErrBadBps haveBps)) + +guardChunk :: String -> Maybe c -> Either ConvertErr c +guardChunk name = maybe (Left (ConvertErrMissingChunk name)) Right + +data LoopMarks a = LoopMarks + { lmStart :: !a + , lmLoopStart :: !a + , lmLoopEnd :: !a + , lmEnd :: !a + } + deriving stock (Eq, Show, Functor, Foldable, Traversable) + +type LoopMarkNames = LoopMarks ShortByteString + +type LoopMarkPoints = LoopMarks (Int, SimpleMarker) + +type LoopMarkOffsets = LoopMarks Int + +defaultLoopMarkNames :: LoopMarkNames +defaultLoopMarkNames = LoopMarks "Start" "LoopStart" "LoopEnd" "End" + +defineLoopMarks :: (Integral a) => LoopMarkNames -> LoopMarks a -> LoopMarkPoints +defineLoopMarks (LoopMarks nw nx ny nz) (LoopMarks pw px py pz) = + LoopMarks + (0, SimpleMarker nw (fromIntegral pw)) + (1, SimpleMarker nx (fromIntegral px)) + (2, SimpleMarker ny (fromIntegral py)) + (3, SimpleMarker nz (fromIntegral pz)) + +findMark :: ShortByteString -> Seq SimpleMarker -> Either ConvertErr (Int, SimpleMarker) +findMark name marks = + case Seq.findIndexL (\sm -> smName sm == name) marks of + Nothing -> Left (ConvertErrMissingMark name) + Just ix -> Right (ix, Seq.index marks ix) + +findLoopMarks :: LoopMarkNames -> Seq SimpleMarker -> Either ConvertErr LoopMarkPoints +findLoopMarks names marks = traverse (`findMark` marks) names + +recallLoopMarkNames :: LoopMarkPoints -> LoopMarkNames +recallLoopMarkNames = fmap (smName . snd) + +-- | Midi note C5 is default note +defaultNoteNumber :: Int +defaultNoteNumber = 72 + +adjustMarker :: Word32 -> SimpleMarker -> SimpleMarker +adjustMarker amt (SimpleMarker name pos) = SimpleMarker name (amt + pos) + +adjustLoopPoints :: Word32 -> LoopMarkPoints -> LoopMarkPoints +adjustLoopPoints = fmap . fmap . adjustMarker diff --git a/src/Dahdit/Audio/Convert.hs b/src/Dahdit/Audio/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Convert.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE RecordWildCards #-} + +module Dahdit.Audio.Convert + ( convertMod + , convertModGeneric + , loadAiff + , loadWav + , Neutral (..) + , aiffToNeutral + , wavToNeutral + , loadNeutral + , neutralToWav + , neutralMono + , neutralCrossFade + , neutralCropLoop + , neutralToSampleWav + , neutralToMonoWav + ) +where + +import Control.Monad (unless, (>=>)) +import Dahdit (Int16LE, Int24LE, Int32LE, Seq (..), StaticByteSized, decodeFile) +import Dahdit.Audio.Aiff (Aiff, aiffGatherMarkers, aiffToPcmContainer) +import Dahdit.Audio.Common + ( ConvertErr (..) + , LoopMarkNames + , LoopMarkPoints + , LoopMarks (..) + , SimpleMarker (..) + , adjustMarker + , findLoopMarks + , recallLoopMarkNames + , rethrow + ) +import Dahdit.Audio.Dsp + ( Mod + , PcmContainer (..) + , PcmMeta (..) + , SampleCount + , applyMod + , applyModGeneric + , changeBitDepth + , crop + , ensureMonoFromLeft + , linearCrossFade + ) +import Dahdit.Audio.Wav + ( Wav + , WavChunk (..) + , wavAddChunks + , wavFromPcmContainer + , wavGatherMarkers + , wavToPcmContainer + , wavUseLoopPoints + , wavUseMarkers + ) +import Data.Maybe (isJust) +import Data.Primitive (Prim) +import Data.Sequence qualified as Seq +import System.FilePath (splitExtension) + +convertMod + :: (StaticByteSized a, Prim b, StaticByteSized b) => Mod a b -> PcmContainer -> Either ConvertErr PcmContainer +convertMod modx con = either (Left . ConvertErrDsp) Right (applyMod modx con) + +convertModGeneric + :: (forall a. (Prim a, StaticByteSized a, Integral a) => Mod a a) -> PcmContainer -> Either ConvertErr PcmContainer +convertModGeneric modx con = either (Left . ConvertErrDsp) Right (applyModGeneric modx con) + +loadAiff :: FilePath -> IO Aiff +loadAiff = decodeFile >=> rethrow . fst + +loadWav :: FilePath -> IO Wav +loadWav = decodeFile >=> rethrow . fst + +data Neutral = Neutral + { neCon :: !PcmContainer + , neMarks :: !(Seq SimpleMarker) + , neLoopMarks :: !(Maybe LoopMarkPoints) + } + deriving stock (Eq, Show) + +guardSr :: Int -> Neutral -> IO () +guardSr expectedSr ne = do + let actualSr = pmSampleRate (pcMeta (neCon ne)) + unless (expectedSr == actualSr) (fail ("Expected SR: " ++ show expectedSr ++ " but got " ++ show actualSr)) + +-- NOTE: Taking sr as a param here so we don't have to interpret extended fp +aiffToNeutral :: Int -> Aiff -> Maybe LoopMarkNames -> Either ConvertErr Neutral +aiffToNeutral sr aiff mayNames = do + neCon <- aiffToPcmContainer sr aiff + let !neMarks = aiffGatherMarkers aiff + neLoopMarks <- maybe (pure Nothing) (fmap Just . (`findLoopMarks` neMarks)) mayNames + pure $! Neutral {..} + +wavToNeutral :: Wav -> Maybe LoopMarkNames -> Either ConvertErr Neutral +wavToNeutral wav mayNames = do + neCon <- wavToPcmContainer wav + let !neMarks = wavGatherMarkers wav + neLoopMarks <- maybe (pure Nothing) (fmap Just . (`findLoopMarks` neMarks)) mayNames + pure $! Neutral {..} + +loadNeutral :: Int -> Maybe LoopMarkNames -> FilePath -> IO Neutral +loadNeutral sr mayNames fp = do + let (_, ext) = splitExtension fp + ne <- + if + | ext == ".wav" -> do + wav <- loadWav fp + rethrow (wavToNeutral wav mayNames) + | ext == ".aif" || ext == ".aifc" || ext == ".aiff" -> do + aiff <- loadAiff fp + rethrow (aiffToNeutral sr aiff mayNames) + | otherwise -> fail ("Could not load with unknown extension: " ++ fp) + guardSr sr ne + pure ne + +neutralToWav :: Int -> Neutral -> Wav +neutralToWav note (Neutral {..}) = + let !sr = pmSampleRate (pcMeta neCon) + !maySampleChunk = fmap (WavChunkSample . wavUseLoopPoints sr note) neLoopMarks + !markChunks = if Seq.null neMarks then [] else let (!wcc, !wac) = wavUseMarkers neMarks in [WavChunkCue wcc, WavChunkAdtl wac] + !chunks = Seq.fromList (markChunks ++ maybe [] pure maySampleChunk) + !wav = wavFromPcmContainer neCon + in wavAddChunks chunks wav + +neutralMono :: Neutral -> Either ConvertErr Neutral +neutralMono ne@(Neutral {..}) = do + con' <- convertModGeneric ensureMonoFromLeft neCon + pure $! ne {neCon = con'} + +neutralReduceDepth :: Neutral -> Either ConvertErr Neutral +neutralReduceDepth ne@(Neutral {..}) = do + case pmBitsPerSample (pcMeta neCon) of + 16 -> pure ne + 24 -> do + con' <- convertMod (changeBitDepth @Int24LE @Int16LE 24 16) neCon + pure $! ne {neCon = con'} + 32 -> do + con' <- convertMod (changeBitDepth @Int32LE @Int16LE 32 16) neCon + pure $! ne {neCon = con'} + y -> Left (ConvertErrBadBps y) + +neutralCrossFade :: SampleCount -> Neutral -> Either ConvertErr Neutral +neutralCrossFade width ne@(Neutral {..}) = do + LoopMarks _ (_, !loopStart) (_, !loopEnd) _ <- maybe (Left ConvertErrNoLoopMarks) Right neLoopMarks + let !loopStartPos = smPosition loopStart + !loopEndPos = smPosition loopEnd + con' <- convertModGeneric (linearCrossFade width (fromIntegral loopStartPos) (fromIntegral loopEndPos)) neCon + pure $! ne {neCon = con'} + +neutralCropLoop :: Neutral -> Either ConvertErr Neutral +neutralCropLoop (Neutral {..}) = do + initLoopMarks <- maybe (Left ConvertErrNoLoopMarks) Right neLoopMarks + let !names = recallLoopMarkNames initLoopMarks + LoopMarks (_, !start) _ (_, !loopEnd) (_, !end) = initLoopMarks + !startPos = smPosition start + !loopEndPos = smPosition loopEnd + !endPos = smPosition end + !filteredMarks = Seq.filter (\sm -> let p = smPosition sm in p >= startPos && p <= loopEndPos) neMarks + !withEndMarks = if endPos <= loopEndPos then filteredMarks else filteredMarks :|> end {smPosition = loopEndPos} + !finalMarks = fmap (adjustMarker (-startPos)) withEndMarks + !finalLoopMarks <- findLoopMarks names finalMarks + con' <- convertModGeneric (crop (fromIntegral startPos) (fromIntegral loopEndPos)) neCon + pure $! Neutral {neCon = con', neLoopMarks = Just finalLoopMarks, neMarks = finalMarks} + +neutralIfHasMarks :: (Neutral -> Either e Neutral) -> Neutral -> Either e Neutral +neutralIfHasMarks f ne = do + if isJust (neLoopMarks ne) + then f ne + else Right ne + +-- | Example converting to instrument sample representing a particular note (with loop marks) +neutralToSampleWav :: SampleCount -> Int -> Neutral -> Either ConvertErr Wav +neutralToSampleWav width note ne = + fmap + (neutralToWav note) + ( neutralMono ne + >>= neutralReduceDepth + >>= neutralIfHasMarks (neutralCrossFade width) + >>= neutralIfHasMarks neutralCropLoop + ) + +-- | Example simply converting to mono 16-bit +neutralToMonoWav :: Neutral -> Either ConvertErr Wav +neutralToMonoWav ne = fmap (wavFromPcmContainer . neCon) (neutralMono ne >>= neutralReduceDepth) diff --git a/src/Dahdit/Audio/Dsp.hs b/src/Dahdit/Audio/Dsp.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Dsp.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE RecordWildCards #-} + +module Dahdit.Audio.Dsp + ( SampleCount (..) + , DspErr (..) + , monoFromLeft + , monoFromRight + , monoFromAvg + , ensureMonoFromLeft + , changeBitDepth + , stereoFromMono + , linearCrossFade + , crop + , ModMeta (..) + , Mod (..) + , modId + , modAndThen + , PcmMeta (..) + , PcmContainer (..) + , applyMod + , applyModGeneric + ) +where + +import Control.Exception (Exception) +import Control.Monad (unless) +import Dahdit + ( ByteCount (..) + , ElemCount (..) + , Int16LE + , Int24LE + , Int32LE + , Int8 + , StaticByteSized + , proxyForF + , staticByteSize + ) +import Data.Bits (Bits (..)) +import Data.Coerce (coerce) +import Data.Primitive (Prim) +import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray) +import Data.Primitive.PrimArray (PrimArray (..), clonePrimArray, generatePrimArray, indexPrimArray, sizeofPrimArray) +import Data.Proxy (Proxy (..)) +import Data.Word (Word64) + +newtype SampleCount = SampleCount {unSampleCount :: Int} + deriving stock (Show) + deriving newtype (Eq, Ord, Num, Enum, Real, Integral) + +data Sampled f where + Sampled :: (Prim a, StaticByteSized a, Integral a) => !(f a) -> Sampled f + +getSampled :: Int -> Maybe (Sampled Proxy) +getSampled = \case + 8 -> Just (Sampled (Proxy :: Proxy Int8)) + 16 -> Just (Sampled (Proxy :: Proxy Int16LE)) + 24 -> Just (Sampled (Proxy :: Proxy Int24LE)) + 32 -> Just (Sampled (Proxy :: Proxy Int32LE)) + _ -> Nothing + +data DspErr + = DspErrOddSamples + | DspErrBadElemSize + | DspErrBadBitWidth + | DspErrNotStereo + | DspErrNotMono + | DspErrBadFade + | DspErrBadCrop + deriving stock (Eq, Show) + +instance Exception DspErr + +newtype Sel a = Sel {runSel :: PrimArray a -> ElemCount -> a} + +selMonoLeft, selMonoRight :: (Prim a) => Sel a +selMonoLeft = Sel $ \arr i -> indexPrimArray arr (unElemCount i * 2) +selMonoRight = Sel $ \arr i -> indexPrimArray arr (unElemCount i * 2 + 1) + +selMonoAvg :: (Prim a, Integral a, Bits a) => Sel a +selMonoAvg = Sel $ \arr i -> + let !ix = i * 2 + !lval = indexPrimArray arr (unElemCount ix) + !rval = indexPrimArray arr (unElemCount ix + 1) + !halfLval = div lval 2 + !halfRval = div rval 2 + !extra = lval .&. rval .&. 1 + in halfLval + halfRval + extra + +data ModMeta = ModMeta + { mmNumChannels :: !Int + , mmBitsPerSample :: !Int + , mmSampleRate :: !Int + } + deriving stock (Eq, Show) + +-- Array layout: samples are interspersed: [chan1 samp1, chan2 samp1, chan1 samp2, chan2 samp2, chan1 samp3, ...] +-- numChannels -> array -> (newNumChannels, newArray) +newtype Mod a b = Mod {runMod :: ModMeta -> PrimArray a -> Either DspErr (ModMeta, PrimArray b)} + +modId :: Mod a a +modId = Mod (curry Right) + +modAndThen :: Mod a b -> Mod b c -> Mod a c +modAndThen modAB modBC = Mod $ \nc src -> do + (nc', src') <- runMod modAB nc src + runMod modBC nc' src' + +monoFromSel :: (Prim a) => Sel a -> Mod a a +monoFromSel sel = Mod $ \mm src -> do + unless (mmNumChannels mm == 2) (Left DspErrNotStereo) + let !srcLen = sizeofPrimArray src + unless (even srcLen) (Left DspErrOddSamples) + let !destLen = div srcLen 2 + !dest = generatePrimArray destLen (runSel sel src . ElemCount) + Right (mm {mmNumChannels = 1}, dest) + +monoFromLeft, monoFromRight :: (Prim a) => Mod a a +monoFromLeft = monoFromSel selMonoLeft +monoFromRight = monoFromSel selMonoRight + +monoFromAvg :: (Prim a, Integral a, Bits a) => Mod a a +monoFromAvg = monoFromSel selMonoAvg + +ensureMonoFromSel :: (Prim a) => Sel a -> Mod a a +ensureMonoFromSel sel = Mod $ \mm src -> do + if mmNumChannels mm == 1 + then pure (mm, src) + else runMod (monoFromSel sel) mm src + +ensureMonoFromLeft :: (Prim a) => Mod a a +ensureMonoFromLeft = ensureMonoFromSel selMonoLeft + +changeBitDepth :: (Prim a, Integral a, Prim b, Num b) => Int -> Int -> Mod a b +changeBitDepth srcBitDepth destBitDepth = Mod $ \mm0 src -> + let bitShift = destBitDepth - srcBitDepth + in pure $ + let mm1 = mm0 {mmBitsPerSample = destBitDepth} + dest = generatePrimArray (sizeofPrimArray src) $ \i -> + let x = indexPrimArray src i + y = shift (fromIntegral @_ @Word64 x) bitShift + in fromIntegral y + in (mm1, dest) + +stereoFromMono :: (Prim a) => Mod a a +stereoFromMono = Mod $ \mm src -> do + unless (mmNumChannels mm == 1) (Left DspErrNotMono) + let !srcLen = sizeofPrimArray src + !destLen = srcLen * 2 + !dest = generatePrimArray destLen (\i -> indexPrimArray src (div i 2)) + Right (mm {mmNumChannels = 2}, dest) + +guardFade :: SampleCount -> SampleCount -> SampleCount -> Either DspErr () +guardFade width loopStart loopEnd = do + if width <= 0 + || loopEnd <= loopStart + || loopStart <= loopStart - width + || loopStart + width <= loopStart + || loopEnd <= loopEnd - width + || loopEnd + width <= loopEnd + then Left DspErrBadFade + else Right () + +combine :: (Integral a) => Int -> Int -> a -> a -> a +combine intDistTot intDist1 one two = + let dist1 = fromIntegral intDist1 + dist2 = fromIntegral (intDistTot - intDist1) + distTot = fromIntegral intDistTot + in fromInteger (div (dist1 * fromIntegral one + dist2 * fromIntegral two) distTot) + +-- Cross fade: | --------- PreStart Start PostStart PreEnd End PostEnd ---- | +-- Guarded to ensure inequalities are strict +-- Width here is one-sided +-- Width is number of samples to fade over +linearCrossFade :: (Prim a, Integral a) => SampleCount -> SampleCount -> SampleCount -> Mod a a +linearCrossFade width loopStart loopEnd = Mod $ \mm src -> do + guardFade width loopStart loopEnd + let !nc = mmNumChannels mm + !sampWidth = nc * unSampleCount width + !sampTotDist = 2 * sampWidth + !sampBetween = nc * unSampleCount (loopEnd - loopStart) + !sampPreStart = nc * unSampleCount (loopStart - width) + !sampStart = nc * unSampleCount loopStart + !sampPostStart = nc * unSampleCount (loopStart + width) + !sampPreEnd = nc * unSampleCount (loopEnd - width) + !sampEnd = nc * unSampleCount loopStart + !sampPostEnd = nc * unSampleCount (loopEnd + width) + !sz = sizeofPrimArray src + !sampLast = sz - sampBetween + genElem i = + let !v = indexPrimArray src i + in if + | i >= sampPreStart && i <= sampPostStart -> + if i >= sampLast + then v + else + let !w = indexPrimArray src (i + sampBetween) + f = combine sampTotDist (coerce (sampPostStart - i)) + in if i < sampStart then f v w else f w v + | i >= sampPreEnd && i <= sampPostEnd -> + if i < sampBetween + then v + else + let !w = indexPrimArray src (i - sampBetween) + f = combine sampTotDist (coerce (sampPostEnd - i)) + in if i < sampEnd then f v w else f w v + | otherwise -> v + !dest = generatePrimArray sz genElem + Right (mm, dest) + +guardCrop :: SampleCount -> SampleCount -> Either DspErr () +guardCrop start end = do + if end <= start + then Left DspErrBadCrop + else Right () + +crop :: (Prim a) => SampleCount -> SampleCount -> Mod a a +crop start end = Mod $ \mm src -> do + guardCrop start end + let !nc = mmNumChannels mm + !sampStart = nc * unSampleCount start + !sampEnd = nc * unSampleCount end + !dest = clonePrimArray src sampStart (sampEnd - sampStart) + Right (mm, dest) + +data PcmMeta = PcmMeta + { pmNumChannels :: !Int + , pmNumSamples :: !SampleCount + , pmBitsPerSample :: !Int + , pmSampleRate :: !Int + } + deriving stock (Eq, Show) + +data PcmContainer = PcmContainer + { pcMeta :: !PcmMeta + , pcData :: !ByteArray + } + deriving stock (Eq, Show) + +pmToMm :: PcmMeta -> ModMeta +pmToMm (PcmMeta {..}) = ModMeta {mmNumChannels = pmNumChannels, mmBitsPerSample = pmBitsPerSample, mmSampleRate = pmSampleRate} + +toLifted :: (StaticByteSized a) => Proxy a -> PcmContainer -> Either DspErr (ModMeta, PrimArray a) +toLifted prox (PcmContainer pm arr@(ByteArray ba)) = do + let !elemSize = staticByteSize prox + let !actualNs = div (sizeofByteArray arr) (unByteCount elemSize * pmNumChannels pm) + unless + (unByteCount elemSize * 8 == pmBitsPerSample pm && actualNs == unSampleCount (pmNumSamples pm)) + (Left DspErrBadElemSize) + let !mm = pmToMm pm + Right (mm, PrimArray ba) + +fromLifted :: (Prim b, StaticByteSized b) => ModMeta -> PrimArray b -> Either DspErr PcmContainer +fromLifted mm arr@(PrimArray ba) = do + let !elemSize = staticByteSize (proxyForF arr) + !nc = mmNumChannels mm + !ns = div (sizeofPrimArray arr) nc + !bps = unByteCount elemSize * 8 + !sr = mmSampleRate mm + !extraElems = rem (sizeofPrimArray arr) nc + unless (extraElems == 0) (Left DspErrBadElemSize) + let !pm = PcmMeta nc (SampleCount ns) bps sr + Right $! PcmContainer pm (ByteArray ba) + +proxyFromFirst :: m a b -> Proxy a +proxyFromFirst _ = Proxy + +applyMod :: (StaticByteSized a, Prim b, StaticByteSized b) => Mod a b -> PcmContainer -> Either DspErr PcmContainer +applyMod modx con = do + (mm, src) <- toLifted (proxyFromFirst modx) con + (mm', dest) <- runMod modx mm src + fromLifted mm' dest + +proxMod + :: (Prim a, StaticByteSized a, Integral a) + => Proxy a + -> (forall x. (Prim x, StaticByteSized x, Integral x) => Mod x x) + -> Mod a a +proxMod _ allMod = allMod + +applyModGeneric + :: (forall a. (Prim a, StaticByteSized a, Integral a) => Mod a a) -> PcmContainer -> Either DspErr PcmContainer +applyModGeneric allMod con = + case getSampled (pmBitsPerSample (pcMeta con)) of + Nothing -> Left DspErrBadBitWidth + Just (Sampled prox) -> applyMod (proxMod prox allMod) con diff --git a/src/Dahdit/Audio/Quiet.hs b/src/Dahdit/Audio/Quiet.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Quiet.hs @@ -0,0 +1,28 @@ +module Dahdit.Audio.Quiet + ( QuietByteArray (..) + , QuietPrimArray (..) + ) +where + +import Data.Default (Default (..)) +import Data.Primitive (Prim) +import Data.Primitive.ByteArray (ByteArray, emptyByteArray, sizeofByteArray) +import Data.Primitive.PrimArray (PrimArray, emptyPrimArray, sizeofPrimArray) + +newtype QuietByteArray = QuietByteArray {unQuietByteArray :: ByteArray} + deriving newtype (Eq, Ord) + +instance Show QuietByteArray where + show (QuietByteArray arr) = "QuietByteArray{" ++ show (sizeofByteArray arr) ++ "}" + +instance Default QuietByteArray where + def = QuietByteArray emptyByteArray + +newtype QuietPrimArray a = QuietPrimArray {unQuietPrimArray :: PrimArray a} + deriving newtype (Eq, Ord) + +instance (Prim a) => Show (QuietPrimArray a) where + show (QuietPrimArray arr) = "QuietPrimArray{" ++ show (sizeofPrimArray arr) ++ "}" + +instance Default (QuietPrimArray a) where + def = QuietPrimArray emptyPrimArray diff --git a/src/Dahdit/Audio/Riff.hs b/src/Dahdit/Audio/Riff.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Riff.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +module Dahdit.Audio.Riff + ( labelRiff + , labelList + , listChunkHeaderSize + , Chunk (..) + , KnownChunk (..) + , ListChunkBody (..) + , ListChunk (..) + , KnownListChunk (..) + , KnownOptChunk (..) + , ChunkLabel (..) + , peekChunkLabel + ) +where + +import Control.Monad (unless) +import Dahdit + ( Binary (..) + , ByteCount + , Get + , StaticByteSized (..) + , byteSizeFoldable + , getExact + , getLookAhead + , getRemainingSeq + , getSkip + , putSeq + , putWord8 + ) +import Dahdit.Audio.Common + ( ChunkHeaderSize + , KnownLabel (..) + , Label + , LabelSize + , PadCount + , chunkHeaderSize + , countSize + , getChunkSizeLE + , getExpectLabel + , labelSize + , padCount + , putChunkSizeLE + ) +import Data.Default (Default) +import Data.Proxy (Proxy (..)) +import Data.Sequence (Seq) +import GHC.TypeLits (Nat, type (+)) + +labelRiff, labelList :: Label +labelRiff = "RIFF" +labelList = "LIST" + +type ListChunkHeaderSize = (ChunkHeaderSize + LabelSize) :: Nat + +listChunkHeaderSize :: ByteCount +listChunkHeaderSize = chunkHeaderSize + labelSize + +data Chunk a = Chunk + { chunkLabel :: !Label + , chunkBody :: !a + } + deriving stock (Eq, Show) + +chunkUnpaddedByteSize :: (Binary a) => Chunk a -> ByteCount +chunkUnpaddedByteSize (Chunk _ body) = byteSize body + +instance (StaticByteSized a) => StaticByteSized (Chunk a) where + type StaticSize (Chunk a) = PadCount (ChunkHeaderSize + StaticSize a) + +instance (Binary a) => Binary (Chunk a) where + byteSize c = padCount (chunkHeaderSize + chunkUnpaddedByteSize c) + get = do + lab <- get + usz <- getChunkSizeLE + body <- getExact usz get + unless (even usz) (getSkip 1) + pure $! Chunk lab body + put c@(Chunk lab body) = do + put lab + let !usz = chunkUnpaddedByteSize c + putChunkSizeLE usz + put body + unless (even usz) (putWord8 0) + +newtype KnownChunk a = KnownChunk + { knownChunkBody :: a + } + deriving stock (Show) + deriving newtype (Eq, Default) + +knownChunkUnpaddedByteSize :: (Binary a) => KnownChunk a -> ByteCount +knownChunkUnpaddedByteSize (KnownChunk body) = byteSize body + +instance (StaticByteSized a) => StaticByteSized (KnownChunk a) where + type StaticSize (KnownChunk a) = PadCount (ChunkHeaderSize + StaticSize a) + +instance (Binary a, KnownLabel a) => Binary (KnownChunk a) where + byteSize c = padCount (chunkHeaderSize + knownChunkUnpaddedByteSize c) + get = do + getExpectLabel (knownLabel (Proxy :: Proxy a)) + usz <- getChunkSizeLE + body <- getExact usz get + unless (even usz) (getSkip 1) + pure $! KnownChunk body + put kc@(KnownChunk body) = do + put (knownLabel (Proxy :: Proxy a)) + let !usz = knownChunkUnpaddedByteSize kc + putChunkSizeLE usz + put body + unless (even usz) (putWord8 0) + +data ListChunkBody a = ListChunkBody + { lcbLabel :: !Label + , lcbItems :: !(Seq a) + } + deriving stock (Eq, Show) + +instance (Binary a) => Binary (ListChunkBody a) where + byteSize (ListChunkBody _ items) = labelSize + byteSizeFoldable items + get = do + label <- get + items <- getRemainingSeq get + pure $! ListChunkBody label items + put (ListChunkBody label items) = do + put label + putSeq put items + +instance KnownLabel (ListChunkBody a) where + knownLabel _ = labelList + +newtype ListChunk a = ListChunk {unListChunk :: KnownChunk (ListChunkBody a)} + deriving stock (Show) + deriving newtype (Eq, Binary) + +newtype KnownListChunk a = KnownListChunk + { klcItems :: Seq a + } + deriving stock (Show) + deriving newtype (Eq, Default) + +instance (Binary a, KnownLabel a) => Binary (KnownListChunk a) where + byteSize (KnownListChunk body) = padCount (listChunkHeaderSize + byteSizeFoldable body) + get = do + getExpectLabel labelList + usz <- getChunkSizeLE + items <- getExact usz $ do + getExpectLabel (knownLabel (Proxy :: Proxy a)) + getRemainingSeq get + unless (even usz) (getSkip 1) + pure $! KnownListChunk items + put (KnownListChunk items) = do + put labelList + let !usz = labelSize + byteSizeFoldable items + putChunkSizeLE usz + put (knownLabel (Proxy :: Proxy a)) + putSeq put items + unless (even usz) (putWord8 0) + +newtype KnownOptChunk a = KnownOptChunk + { kocItem :: Maybe a + } + deriving stock (Show) + deriving newtype (Eq, Default) + +instance (Binary a, KnownLabel a) => Binary (KnownOptChunk a) where + byteSize (KnownOptChunk item) = padCount (listChunkHeaderSize + byteSizeFoldable item) + get = do + getExpectLabel labelList + usz <- getChunkSizeLE + item <- getExact usz $ do + let !label = knownLabel (Proxy :: Proxy a) + getExpectLabel label + if usz == labelSize + then pure Nothing + else fmap Just get + unless (even usz) (getSkip 1) + pure $! KnownOptChunk item + put (KnownOptChunk item) = do + put labelList + let !usz = labelSize + byteSizeFoldable item + putChunkSizeLE usz + put (knownLabel (Proxy :: Proxy a)) + maybe (pure ()) put item + unless (even usz) (putWord8 0) + +data ChunkLabel + = ChunkLabelSingle !Label + | ChunkLabelList !Label + deriving stock (Eq, Show) + +peekChunkLabel :: Get ChunkLabel +peekChunkLabel = getLookAhead $ do + label <- get + if label == labelList + then getSkip countSize *> fmap ChunkLabelList get + else pure (ChunkLabelSingle label) diff --git a/src/Dahdit/Audio/Sfont.hs b/src/Dahdit/Audio/Sfont.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Sfont.hs @@ -0,0 +1,844 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module Dahdit.Audio.Sfont + ( Sfont (..) + , InfoChunk (..) + , PdtaChunk (..) + , SdtaChunk (..) + , Info (..) + , Sdta (..) + , PdtaCat (..) + , PdtaBlock (..) + , Pdta (..) + , Phdr (..) + , Bag (..) + , Mod (..) + , Gen (..) + , GenPair (..) + , GenTag (..) + , defGenVal + , lookupGenVal + , Inst (..) + , Shdr (..) + , buildPdta + , labelSfbk + ) +where + +import Control.Monad (unless) +import Dahdit + ( Binary (..) + , ByteCount (..) + , Get + , Int16LE (..) + , Put + , ShortByteString + , StaticByteSized (..) + , StaticBytes + , TermBytes16 + , ViaStaticGeneric (..) + , Word16LE + , Word32LE + , byteSizeViaStatic + , getExact + , getPrimArray + , getRemainingSeq + , getRemainingSize + , getRemainingStaticSeq + , getRemainingString + , getSkip + , putByteString + , putPrimArray + , putSeq + ) +import Dahdit.Audio.Common + ( KnownLabel (..) + , Label + , chunkHeaderSize + , getChunkSizeLE + , getExpectLabel + , labelSize + , putChunkSizeLE + ) +import Dahdit.Audio.Riff (KnownListChunk, KnownOptChunk, labelRiff) +import Data.ByteString.Short qualified as BSS +import Data.Foldable (foldl') +import Data.Int (Int8) +import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray) +import Data.Primitive.PrimArray (PrimArray (..)) +import Data.Proxy (Proxy (..)) +import Data.Sequence (Seq (..)) +import Data.Sequence qualified as Seq +import Data.Type.Equality (testEquality) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Type.Reflection (TypeRep, Typeable, typeRep, (:~:) (..)) + +labelSfbk + , labelInfo + , labelIfil + , labelIver + , labelIsng + , labelInam + , labelIrom + , labelIcrd + , labelIeng + , labelIprd + , labelIcop + , labelIcmt + , labelIsft + , labelSdta + , labelSmpl + , labelSm24 + , labelPdta + , labelPhdr + , labelPbag + , labelPmod + , labelPgen + , labelInst + , labelIbag + , labelImod + , labelIgen + , labelShdr + :: Label +labelSfbk = "sfbk" +labelInfo = "INFO" +labelIfil = "ifil" +labelIver = "iver" +labelIsng = "isng" +labelInam = "INAM" +labelIrom = "irom" +labelIcrd = "ICRD" +labelIeng = "IENG" +labelIprd = "IPRD" +labelIcop = "ICOP" +labelIcmt = "ICMT" +labelIsft = "ISFT" +labelSdta = "sdta" +labelSmpl = "smpl" +labelSm24 = "sm24" +labelPdta = "pdta" +labelPhdr = "phdr" +labelPbag = "pbag" +labelPmod = "pmod" +labelPgen = "pgen" +labelInst = "inst" +labelIbag = "ibag" +labelImod = "imod" +labelIgen = "igen" +labelShdr = "shdr" + +newtype SampleCount = SampleCount {unSampleCount :: Word32LE} + deriving stock (Show) + deriving newtype (Eq, Ord, Num, Enum, Real, Integral, StaticByteSized, Binary) + +type ShortText = StaticBytes 20 + +data Sfont = Sfont + { sfontInfo :: !InfoChunk + , sfontSdta :: !SdtaChunk + , sfontPdta :: !PdtaChunk + } + deriving stock (Eq, Show) + +instance Binary Sfont where + byteSize (Sfont info sdta pdta) = chunkHeaderSize + labelSize + byteSize info + byteSize sdta + byteSize pdta + get = do + getExpectLabel labelRiff + chunkSize <- getChunkSizeLE + getExact chunkSize $ do + getExpectLabel labelSfbk + info <- get + sdta <- get + pdta <- get + pure $! Sfont info sdta pdta + put sfont@(Sfont info sdta pdta) = do + put labelRiff + let !chunkSize = byteSize sfont - chunkHeaderSize + putChunkSizeLE chunkSize + put labelSfbk + put info + put sdta + put pdta + +newtype InfoChunk = InfoChunk {unInfoChunk :: KnownListChunk Info} + deriving stock (Show) + deriving newtype (Eq, Binary) + +newtype PdtaChunk = PdtaChunk {unPdtaChunk :: KnownListChunk PdtaBlock} + deriving stock (Show) + deriving newtype (Eq, Binary) + +data Info + = InfoVersion !Word16LE !Word16LE + | InfoTargetSoundEngine !TermBytes16 + | InfoBankName !TermBytes16 + | InfoRomName !TermBytes16 + | InfoRomVersion !Word16LE !Word16LE + | InfoCreationDate !TermBytes16 + | InfoAuthors !TermBytes16 + | InfoIntendedProduct !TermBytes16 + | InfoCopyrightMessage !TermBytes16 + | InfoComments !TermBytes16 + | InfoUsedTools !TermBytes16 + | InfoReserved !Label !ShortByteString + deriving stock (Eq, Show) + +instance KnownLabel Info where + knownLabel _ = labelInfo + +whichLabelInfo :: Info -> Label +whichLabelInfo = \case + InfoVersion _ _ -> labelIfil + InfoRomVersion _ _ -> labelIver + InfoTargetSoundEngine _ -> labelIsng + InfoBankName _ -> labelInam + InfoRomName _ -> labelIrom + InfoCreationDate _ -> labelIcrd + InfoAuthors _ -> labelIeng + InfoIntendedProduct _ -> labelIprd + InfoCopyrightMessage _ -> labelIcop + InfoComments _ -> labelIcmt + InfoUsedTools _ -> labelIsft + InfoReserved l _ -> l + +instance Binary Info where + byteSize info = + chunkHeaderSize + case info of + InfoVersion _ _ -> 4 + InfoTargetSoundEngine z -> byteSize z + InfoBankName z -> byteSize z + InfoRomName z -> byteSize z + InfoRomVersion _ _ -> 4 + InfoCreationDate z -> byteSize z + InfoAuthors z -> byteSize z + InfoIntendedProduct z -> byteSize z + InfoCopyrightMessage z -> byteSize z + InfoComments z -> byteSize z + InfoUsedTools z -> byteSize z + InfoReserved _ bs -> ByteCount (BSS.length bs) + get = do + label <- get + chunkSize <- getChunkSizeLE + getExact chunkSize $ + if + | label == labelIfil -> do + unless (chunkSize == 4) (fail "Bad ifil chunk size") + w1 <- get + w2 <- get + pure $! InfoVersion w1 w2 + | label == labelIver -> do + unless (chunkSize == 4) (fail "Bad iver chunk size") + w1 <- get + w2 <- get + pure $! InfoRomVersion w1 w2 + | label == labelIsng -> fmap InfoTargetSoundEngine get + | label == labelInam -> fmap InfoBankName get + | label == labelIrom -> fmap InfoRomName get + | label == labelIcrd -> fmap InfoCreationDate get + | label == labelIeng -> fmap InfoAuthors get + | label == labelIprd -> fmap InfoIntendedProduct get + | label == labelIcop -> fmap InfoCopyrightMessage get + | label == labelIcmt -> fmap InfoComments get + | label == labelIsft -> fmap InfoUsedTools get + | otherwise -> do + bs <- getRemainingString + pure $! InfoReserved label bs + put info = do + let !label = whichLabelInfo info + put label + let !chunkSize = byteSize info - chunkHeaderSize + putChunkSizeLE chunkSize + case info of + InfoVersion w1 w2 -> put w1 *> put w2 + InfoTargetSoundEngine z -> put z + InfoBankName z -> put z + InfoRomName z -> put z + InfoRomVersion w1 w2 -> put w1 *> put w2 + InfoCreationDate z -> put z + InfoAuthors z -> put z + InfoIntendedProduct z -> put z + InfoCopyrightMessage z -> put z + InfoComments z -> put z + InfoUsedTools z -> put z + InfoReserved _ bs -> putByteString bs + +data Sdta = Sdta + { sdtaHighBits :: !(PrimArray Int16LE) + , sdtaLowBits :: !(Maybe (PrimArray Word8)) + } + deriving stock (Eq, Show) + +instance KnownLabel Sdta where + knownLabel _ = labelSdta + +getHighBits :: SampleCount -> Get (PrimArray Int16LE) +getHighBits numSamples = getPrimArray (Proxy :: Proxy Int16LE) (fromIntegral numSamples) + +getLowBits :: SampleCount -> Get (PrimArray Word8) +getLowBits numSamples = getPrimArray (Proxy :: Proxy Word8) (fromIntegral numSamples) + +instance Binary Sdta where + byteSize (Sdta (PrimArray hba) mlow) = sizeHigh + sizeLow + where + sizeHigh = chunkHeaderSize + ByteCount (sizeofByteArray (ByteArray hba)) + sizeLow = maybe 0 (\(PrimArray lba) -> chunkHeaderSize + ByteCount (sizeofByteArray (ByteArray lba))) mlow + + get = do + chunkSize <- getRemainingSize + getExpectLabel labelSmpl + highSize <- getChunkSizeLE + let !numSamples = div (fromIntegral highSize) 2 + highBits <- getHighBits numSamples + let !numExtra = chunkSize - highSize - chunkHeaderSize + if + | numExtra > 0 -> do + getExpectLabel labelSm24 + lowSize <- getChunkSizeLE + let !expectedSize = if even numSamples then numSamples else numSamples + 1 + unless (fromIntegral lowSize == expectedSize) (fail "invalid low sample size") + lowBits <- getLowBits numSamples + unless (even numSamples) (getSkip 1) + pure $! Sdta highBits (Just lowBits) + | numExtra == 0 -> pure $! Sdta highBits Nothing + | otherwise -> fail "invalid sdata chunk/sample sizes" + put (Sdta high@(PrimArray hba) mlow) = do + put labelSmpl + putChunkSizeLE (ByteCount (sizeofByteArray (ByteArray hba))) + putPrimArray high + case mlow of + Nothing -> pure () + Just low@(PrimArray lba) -> do + put labelSm24 + putChunkSizeLE (ByteCount (sizeofByteArray (ByteArray lba))) + putPrimArray low + +newtype SdtaChunk = SdtaChunk {unSdtaChunk :: KnownOptChunk Sdta} + deriving stock (Show) + deriving newtype (Eq, Binary) + +data PdtaCat + = PdtaCatPreset + | PdtaCatInst + deriving stock (Eq, Show) + +data PdtaBlock + = PdtaBlockPhdr !(Seq Phdr) + | PdtaBlockBag !PdtaCat !(Seq Bag) + | PdtaBlockMod !PdtaCat !(Seq Mod) + | PdtaBlockGen !PdtaCat !(Seq Gen) + | PdtaBlockInst !(Seq Inst) + | PdtaBlockShdr !(Seq Shdr) + deriving stock (Eq, Show) + +instance KnownLabel PdtaBlock where + knownLabel _ = labelPdta + +whichLabelPdtaBlock :: PdtaBlock -> Label +whichLabelPdtaBlock = \case + PdtaBlockPhdr _ -> labelPhdr + PdtaBlockBag pc _ -> case pc of + PdtaCatPreset -> labelPbag + PdtaCatInst -> labelIbag + PdtaBlockMod pc _ -> case pc of + PdtaCatPreset -> labelPmod + PdtaCatInst -> labelImod + PdtaBlockGen pc _ -> case pc of + PdtaCatPreset -> labelPgen + PdtaCatInst -> labelIgen + PdtaBlockInst _ -> labelInst + PdtaBlockShdr _ -> labelShdr + +instance Binary PdtaBlock where + byteSize block = res + where + res = + chunkHeaderSize + case block of + PdtaBlockPhdr phdrs -> fromIntegral (Seq.length phdrs) * sizePhdr + PdtaBlockBag _ bags -> fromIntegral (Seq.length bags) * sizeBag + PdtaBlockMod _ mods -> fromIntegral (Seq.length mods) * sizeMod + PdtaBlockGen _ gens -> fromIntegral (Seq.length gens) * sizeGen + PdtaBlockInst insts -> fromIntegral (Seq.length insts) * sizeInst + PdtaBlockShdr shdrs -> fromIntegral (Seq.length shdrs) * sizeShdr + sizePhdr = staticByteSize (Proxy :: Proxy Phdr) + sizeBag = staticByteSize (Proxy :: Proxy Bag) + sizeMod = staticByteSize (Proxy :: Proxy Mod) + sizeGen = staticByteSize (Proxy :: Proxy Gen) + sizeInst = staticByteSize (Proxy :: Proxy Inst) + sizeShdr = staticByteSize (Proxy :: Proxy Shdr) + + get = do + label <- get + chunkSize <- getChunkSizeLE + getExact chunkSize $ + if + | label == labelPhdr -> + fmap PdtaBlockPhdr (getRemainingStaticSeq get) + | label == labelPbag -> + fmap (PdtaBlockBag PdtaCatPreset) (getRemainingStaticSeq get) + | label == labelPmod -> + fmap (PdtaBlockMod PdtaCatPreset) (getRemainingStaticSeq get) + | label == labelPgen -> + fmap (PdtaBlockGen PdtaCatPreset) (getRemainingStaticSeq get) + | label == labelInst -> + fmap PdtaBlockInst (getRemainingSeq get) + | label == labelIbag -> + fmap (PdtaBlockBag PdtaCatInst) (getRemainingStaticSeq get) + | label == labelImod -> + fmap (PdtaBlockMod PdtaCatInst) (getRemainingStaticSeq get) + | label == labelIgen -> + fmap (PdtaBlockGen PdtaCatInst) (getRemainingStaticSeq get) + | label == labelShdr -> + fmap PdtaBlockShdr (getRemainingStaticSeq get) + | otherwise -> + fail ("unrecognized pdta elem: " ++ show label) + put block = do + let !label = whichLabelPdtaBlock block + put label + let !chunkSize = byteSize block - chunkHeaderSize + putChunkSizeLE chunkSize + case block of + PdtaBlockPhdr phdrs -> putSeq put phdrs + PdtaBlockBag _ bags -> putSeq put bags + PdtaBlockMod _ mods -> putSeq put mods + PdtaBlockGen _ gens -> putSeq put gens + PdtaBlockInst insts -> putSeq put insts + PdtaBlockShdr shdrs -> putSeq put shdrs + +-- | Preset header +data Phdr = Phdr + { phdrPresetName :: !ShortText + , phdrPreset :: !Word16LE + , phdrBank :: !Word16LE + , phdrPresetBagIndex :: !Word16LE + , phdrLibrary :: !Word32LE + , phdrGenre :: !Word32LE + , phdrMorphology :: !Word32LE + } + deriving stock (Eq, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric Phdr) + +data Bag = Bag + { bagGenIndex :: !Word16LE + , bagModIndex :: !Word16LE + } + deriving stock (Eq, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric Bag) + +-- | Modulator +data Mod = Mod + { modSrcOper :: !Word16LE + , modDestOper :: !Word16LE + , modAmount :: !Int16LE + , modAmtSrcOper :: !Word16LE + , modTransOper :: !Word16LE + } + deriving stock (Eq, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric Mod) + +data SampleMode + = SampleModeNoLoop !Int16LE + | SampleModeContLoop + | SampleModePressLoop + deriving stock (Eq, Ord, Show) + +instance StaticByteSized SampleMode where + type StaticSize SampleMode = 2 + staticByteSize _ = 2 + +instance Binary SampleMode where + byteSize = byteSizeViaStatic + get = do + c <- get + pure $! case c of + 1 -> SampleModeContLoop + 3 -> SampleModePressLoop + _ -> SampleModeNoLoop c + put sm = + put $! case sm of + SampleModeContLoop -> 1 + SampleModePressLoop -> 3 + SampleModeNoLoop c -> c + +data Range = Range + { rangeLo :: !Word8 + , rangeHi :: !Word8 + } + deriving stock (Eq, Ord, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric Range) + +data ReservedGen = ReservedGen + { reservedGenTag :: !Word16LE + , reservedGetVal :: !Int16LE + } + deriving stock (Eq, Ord, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric ReservedGen) + +-- | Instrument +data Inst = Inst + { instName :: !ShortText + , instBagIndex :: !Word16LE + } + deriving stock (Eq, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric Inst) + +-- | Sample header +data Shdr = Shdr + { shdrSampleName :: !ShortText + , shdrStart :: !Word32LE + , shdrEnd :: !Word32LE + , shdrStartLoop :: !Word32LE + , shdrEndLoop :: !Word32LE + , shdrSampleRate :: !Word32LE + , shdrOriginalPitch :: !Word8 + , shdrPitchCorrection :: !Int8 + , shdrSampleLink :: !Word16LE + , shdrSampleType :: !Word16LE + } + deriving stock (Eq, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric Shdr) + +data Pdta = Pdta + { pdtaPhdrs :: !(Seq Phdr) + -- ^ Preset headers + , pdtaPbags :: !(Seq Bag) + -- ^ Preset bags + , pdtaPmods :: !(Seq Mod) + -- ^ Preset modulators + , pdtaPgens :: !(Seq Gen) + -- ^ Preset generators + , pdtaInsts :: !(Seq Inst) + -- ^ Instrument names + , pdtaIbags :: !(Seq Bag) + -- ^ Instrument bags + , pdtaImods :: !(Seq Mod) + -- ^ Instrument modulators + , pdtaIgens :: !(Seq Gen) + -- ^ Instrument generators + , pdtaShdrs :: !(Seq Shdr) + -- ^ Sample headers + } + deriving stock (Eq, Show) + +emptyPdta :: Pdta +emptyPdta = Pdta Empty Empty Empty Empty Empty Empty Empty Empty Empty + +buildPdta :: Seq PdtaBlock -> Pdta +buildPdta = foldl' go emptyPdta + where + go p = \case + PdtaBlockPhdr phdrs -> p {pdtaPhdrs = pdtaPhdrs p <> phdrs} + PdtaBlockBag cat bags -> case cat of + PdtaCatPreset -> p {pdtaPbags = pdtaPbags p <> bags} + PdtaCatInst -> p {pdtaIbags = pdtaIbags p <> bags} + PdtaBlockMod cat mods -> case cat of + PdtaCatPreset -> p {pdtaPmods = pdtaPmods p <> mods} + PdtaCatInst -> p {pdtaImods = pdtaImods p <> mods} + PdtaBlockGen cat gens -> case cat of + PdtaCatPreset -> p {pdtaPgens = pdtaPgens p <> gens} + PdtaCatInst -> p {pdtaIgens = pdtaIgens p <> gens} + PdtaBlockInst insts -> p {pdtaInsts = pdtaInsts p <> insts} + PdtaBlockShdr shdrs -> p {pdtaShdrs = pdtaShdrs p <> shdrs} + +-- | Tags for generators +data GenTag a where + GenTagStartAddressOffset :: GenTag Int16LE + GenTagEndAddressOffset :: GenTag Int16LE + GenTagLoopStartAddressOffset :: GenTag Int16LE + GenTagLoopEndAddressOffset :: GenTag Int16LE + GenTagStartAddressCoarseOffset :: GenTag Int16LE + GenTagModLfoToPitch :: GenTag Int16LE + GenTagVibLfoToPitch :: GenTag Int16LE + GenTagModEnvToPitch :: GenTag Int16LE + GenTagInitFc :: GenTag Int16LE + GenTagInitQ :: GenTag Int16LE + GenTagModLfoToFc :: GenTag Int16LE + GenTagModEnvToFc :: GenTag Int16LE + GenTagEndAddressCoarseOffset :: GenTag Int16LE + GenTagModLfoToVol :: GenTag Int16LE + GenTagChorus :: GenTag Int16LE + GenTagReverb :: GenTag Int16LE + GenTagPan :: GenTag Int16LE + GenTagDelayModLfo :: GenTag Int16LE + GenTagFreqModLfo :: GenTag Int16LE + GenTagDelayVibLfo :: GenTag Int16LE + GenTagFreqVibLfo :: GenTag Int16LE + GenTagDelayModEnv :: GenTag Int16LE + GenTagAttackModEnv :: GenTag Int16LE + GenTagHoldModEnv :: GenTag Int16LE + GenTagDecayModEnv :: GenTag Int16LE + GenTagSustainModEnv :: GenTag Int16LE + GenTagReleaseModEnv :: GenTag Int16LE + GenTagKeyToModEnvHold :: GenTag Int16LE + GenTagKeyToModEnvDecay :: GenTag Int16LE + GenTagDelayVolEnv :: GenTag Int16LE + GenTagAttackVolEnv :: GenTag Int16LE + GenTagHoldVolEnv :: GenTag Int16LE + GenTagDecayVolEnv :: GenTag Int16LE + GenTagSustainVolEnv :: GenTag Int16LE + GenTagReleaseVolEnv :: GenTag Int16LE + GenTagKeyToVolEnvHold :: GenTag Int16LE + GenTagKeyToVolEnvDecay :: GenTag Int16LE + GenTagInstIndex :: GenTag Word16LE + GenTagKeyRange :: GenTag Range + GenTagVelRange :: GenTag Range + GenTagLoopStartAddressCoarseOffset :: GenTag Int16LE + GenTagKey :: GenTag Word16LE + GenTagVel :: GenTag Word16LE + GenTagInitAtten :: GenTag Int16LE + GenTagLoopEndAddressCoarseOffset :: GenTag Int16LE + GenTagCoarseTune :: GenTag Int16LE + GenTagFineTune :: GenTag Int16LE + GenTagSampleIndex :: GenTag Word16LE + GenTagSampleMode :: GenTag SampleMode + GenTagScaleTuning :: GenTag Int16LE + GenTagExclusiveClass :: GenTag Int16LE + GenTagRootKey :: GenTag Word16LE + GenTagReserved :: Word16LE -> GenTag Int16LE + +deriving instance Eq (GenTag a) + +deriving instance Ord (GenTag a) + +deriving instance Show (GenTag a) + +genTagRep :: GenTag a -> Word16LE +genTagRep = \case + GenTagStartAddressOffset -> 0 + GenTagEndAddressOffset -> 1 + GenTagLoopStartAddressOffset -> 2 + GenTagLoopEndAddressOffset -> 3 + GenTagStartAddressCoarseOffset -> 4 + GenTagModLfoToPitch -> 5 + GenTagVibLfoToPitch -> 6 + GenTagModEnvToPitch -> 7 + GenTagInitFc -> 8 + GenTagInitQ -> 9 + GenTagModLfoToFc -> 10 + GenTagModEnvToFc -> 11 + GenTagEndAddressCoarseOffset -> 12 + GenTagModLfoToVol -> 13 + GenTagChorus -> 15 + GenTagReverb -> 16 + GenTagPan -> 17 + GenTagDelayModLfo -> 21 + GenTagFreqModLfo -> 22 + GenTagDelayVibLfo -> 23 + GenTagFreqVibLfo -> 24 + GenTagDelayModEnv -> 25 + GenTagAttackModEnv -> 26 + GenTagHoldModEnv -> 27 + GenTagDecayModEnv -> 28 + GenTagSustainModEnv -> 29 + GenTagReleaseModEnv -> 30 + GenTagKeyToModEnvHold -> 31 + GenTagKeyToModEnvDecay -> 32 + GenTagDelayVolEnv -> 33 + GenTagAttackVolEnv -> 34 + GenTagHoldVolEnv -> 35 + GenTagDecayVolEnv -> 36 + GenTagSustainVolEnv -> 37 + GenTagReleaseVolEnv -> 38 + GenTagKeyToVolEnvHold -> 39 + GenTagKeyToVolEnvDecay -> 40 + GenTagInstIndex -> 41 + GenTagKeyRange -> 43 + GenTagVelRange -> 44 + GenTagLoopStartAddressCoarseOffset -> 45 + GenTagKey -> 46 + GenTagVel -> 47 + GenTagInitAtten -> 48 + GenTagLoopEndAddressCoarseOffset -> 50 + GenTagCoarseTune -> 51 + GenTagFineTune -> 52 + GenTagSampleIndex -> 53 + GenTagSampleMode -> 54 + GenTagScaleTuning -> 56 + GenTagExclusiveClass -> 57 + GenTagRootKey -> 58 + GenTagReserved t -> t + +data GenPair a = GenPair + { genPairTag :: !(GenTag a) + , genPairVal :: !a + } + deriving stock (Eq, Ord, Show) + +putGenPair :: (Binary a) => GenPair a -> Put +putGenPair (GenPair tag val) = put (genTagRep tag) *> put val + +data Gen + = GenInt !(GenPair Int16LE) + | GenWord !(GenPair Word16LE) + | GenRange !(GenPair Range) + | GenSampleMode !(GenPair SampleMode) + deriving stock (Eq, Ord, Show) + +getGenInt :: GenTag Int16LE -> Get Gen +getGenInt tag = fmap (GenInt . GenPair tag) get + +getGenWord :: GenTag Word16LE -> Get Gen +getGenWord tag = fmap (GenWord . GenPair tag) get + +getGenRange :: GenTag Range -> Get Gen +getGenRange tag = fmap (GenRange . GenPair tag) get + +getGenSampleMode :: GenTag SampleMode -> Get Gen +getGenSampleMode tag = fmap (GenSampleMode . GenPair tag) get + +instance StaticByteSized Gen where + type StaticSize Gen = 4 + staticByteSize _ = 4 + +instance Binary Gen where + byteSize = byteSizeViaStatic + get = do + tag <- get + case tag of + 0 -> getGenInt GenTagStartAddressOffset + 1 -> getGenInt GenTagEndAddressOffset + 2 -> getGenInt GenTagLoopStartAddressOffset + 3 -> getGenInt GenTagLoopEndAddressOffset + 4 -> getGenInt GenTagStartAddressCoarseOffset + 5 -> getGenInt GenTagModLfoToPitch + 6 -> getGenInt GenTagVibLfoToPitch + 7 -> getGenInt GenTagModEnvToPitch + 8 -> getGenInt GenTagInitFc + 9 -> getGenInt GenTagInitQ + 10 -> getGenInt GenTagModLfoToFc + 11 -> getGenInt GenTagModEnvToFc + 12 -> getGenInt GenTagEndAddressCoarseOffset + 13 -> getGenInt GenTagModLfoToVol + 15 -> getGenInt GenTagChorus + 16 -> getGenInt GenTagReverb + 17 -> getGenInt GenTagPan + 21 -> getGenInt GenTagDelayModLfo + 22 -> getGenInt GenTagFreqModLfo + 23 -> getGenInt GenTagDelayVibLfo + 24 -> getGenInt GenTagFreqVibLfo + 25 -> getGenInt GenTagDelayModEnv + 26 -> getGenInt GenTagAttackModEnv + 27 -> getGenInt GenTagHoldModEnv + 28 -> getGenInt GenTagDecayModEnv + 29 -> getGenInt GenTagSustainModEnv + 30 -> getGenInt GenTagReleaseModEnv + 31 -> getGenInt GenTagKeyToModEnvHold + 32 -> getGenInt GenTagKeyToModEnvDecay + 33 -> getGenInt GenTagDelayVolEnv + 34 -> getGenInt GenTagAttackVolEnv + 35 -> getGenInt GenTagHoldVolEnv + 36 -> getGenInt GenTagDecayVolEnv + 37 -> getGenInt GenTagSustainVolEnv + 38 -> getGenInt GenTagReleaseVolEnv + 39 -> getGenInt GenTagKeyToVolEnvHold + 40 -> getGenInt GenTagKeyToVolEnvDecay + 41 -> getGenWord GenTagInstIndex + 43 -> getGenRange GenTagKeyRange + 44 -> getGenRange GenTagVelRange + 45 -> getGenInt GenTagLoopStartAddressCoarseOffset + 46 -> getGenWord GenTagKey + 47 -> getGenWord GenTagVel + 48 -> getGenInt GenTagInitAtten + 50 -> getGenInt GenTagLoopEndAddressCoarseOffset + 51 -> getGenInt GenTagCoarseTune + 52 -> getGenInt GenTagFineTune + 53 -> getGenWord GenTagSampleIndex + 54 -> getGenSampleMode GenTagSampleMode + 56 -> getGenInt GenTagScaleTuning + 57 -> getGenInt GenTagExclusiveClass + 58 -> getGenWord GenTagRootKey + _ -> getGenInt (GenTagReserved tag) + put = \case + GenInt gp -> putGenPair gp + GenWord gp -> putGenPair gp + GenRange gp -> putGenPair gp + GenSampleMode gp -> putGenPair gp + +defGenVal :: GenTag a -> a +defGenVal = \case + GenTagStartAddressOffset -> 0 + GenTagEndAddressOffset -> 0 + GenTagLoopStartAddressOffset -> 0 + GenTagLoopEndAddressOffset -> 0 + GenTagStartAddressCoarseOffset -> 0 + GenTagModLfoToPitch -> 0 + GenTagVibLfoToPitch -> 0 + GenTagModEnvToPitch -> 0 + GenTagInitFc -> 13500 + GenTagInitQ -> 0 + GenTagModLfoToFc -> 0 + GenTagModEnvToFc -> 0 + GenTagEndAddressCoarseOffset -> 0 + GenTagModLfoToVol -> 0 + GenTagChorus -> 0 + GenTagReverb -> 0 + GenTagPan -> 0 + GenTagDelayModLfo -> -12000 + GenTagFreqModLfo -> 0 + GenTagDelayVibLfo -> -12000 + GenTagFreqVibLfo -> 0 + GenTagDelayModEnv -> -12000 + GenTagAttackModEnv -> -12000 + GenTagHoldModEnv -> -12000 + GenTagDecayModEnv -> -12000 + GenTagSustainModEnv -> 0 + GenTagReleaseModEnv -> -12000 + GenTagKeyToModEnvHold -> 0 + GenTagKeyToModEnvDecay -> 0 + GenTagDelayVolEnv -> -12000 + GenTagAttackVolEnv -> -12000 + GenTagHoldVolEnv -> -12000 + GenTagDecayVolEnv -> -12000 + GenTagSustainVolEnv -> 0 + GenTagReleaseVolEnv -> -12000 + GenTagKeyToVolEnvHold -> 0 + GenTagKeyToVolEnvDecay -> 0 + GenTagInstIndex -> 0 + GenTagKeyRange -> Range 0 127 + GenTagVelRange -> Range 0 127 + GenTagLoopStartAddressCoarseOffset -> 0 + GenTagKey -> -1 + GenTagVel -> -1 + GenTagInitAtten -> 0 + GenTagLoopEndAddressCoarseOffset -> 0 + GenTagCoarseTune -> 0 + GenTagFineTune -> 0 + GenTagSampleIndex -> 0 + GenTagSampleMode -> SampleModeNoLoop 0 + GenTagScaleTuning -> 100 + GenTagExclusiveClass -> 0 + GenTagRootKey -> -1 + GenTagReserved _ -> 0 + +genTagTyRep :: (Typeable a) => GenTag a -> TypeRep a +genTagTyRep _ = typeRep + +genTagTest :: (Typeable a, Typeable b) => GenTag a -> GenTag b -> Maybe (a :~: b) +genTagTest t s = case testEquality (genTagTyRep t) (genTagTyRep s) of + Nothing -> Nothing + Just Refl -> if t == s then Just Refl else Nothing + +lookupGenVal :: (Typeable a) => GenTag a -> Seq Gen -> Maybe a +lookupGenVal t = go + where + go = \case + Empty -> Nothing + gp :<| rest -> + case gp of + GenInt (GenPair s v) -> + case genTagTest t s of + Just Refl -> Just v + Nothing -> go rest + GenWord (GenPair s v) -> + case genTagTest t s of + Just Refl -> Just v + Nothing -> go rest + GenRange (GenPair s v) -> + case genTagTest t s of + Just Refl -> Just v + Nothing -> go rest + GenSampleMode (GenPair s v) -> + case genTagTest t s of + Just Refl -> Just v + Nothing -> go rest diff --git a/src/Dahdit/Audio/Wav.hs b/src/Dahdit/Audio/Wav.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Wav.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoStarIsType #-} + +module Dahdit.Audio.Wav + ( PaddedString (..) + , WavFormatBody (..) + , WavFormatChunk + , WavHeader (..) + , WavDataBody (..) + , WavDataChunk + , WavUnparsedChunk + , WavInfoElem (..) + , WavInfoChunk + , WavAdtlData (..) + , WavAdtlElem (..) + , WavAdtlChunk + , WavCuePoint (..) + , WavCueBody (..) + , WavCueChunk + , WavSampleLoop (..) + , WavSampleBody (..) + , WavSampleChunk + , WavChunk (..) + , Wav (..) + , lookupWavChunk + , lookupWavFormatChunk + , lookupWavDataChunk + , wavToPcmContainer + , wavFromPcmContainer + , wavUseMarkers + , wavUseLoopPoints + , wavAddChunks + , wavGatherMarkers + ) +where + +import Control.Monad (unless) +import Dahdit + ( Binary (..) + , ByteCount (..) + , ShortByteString + , StaticByteSized (..) + , ViaStaticGeneric (..) + , Word16LE + , Word32LE (..) + , byteSizeFoldable + , getExact + , getRemainingByteArray + , getRemainingSeq + , getRemainingString + , getSeq + , putByteArray + , putByteString + , putSeq + , putWord8 + ) +import Dahdit.Audio.Common + ( ConvertErr + , CountSize + , KnownLabel (..) + , Label + , LabelSize + , LoopMarkPoints + , LoopMarks (..) + , SimpleMarker (..) + , UnparsedBody (..) + , countSize + , dedupeSimpleMarkers + , getChunkSizeLE + , getExpectLabel + , guardChunk + , labelSize + , padCount + , putChunkSizeLE + ) +import Dahdit.Audio.Dsp (PcmContainer (..), PcmMeta (..), SampleCount (..)) +import Dahdit.Audio.Riff (Chunk (..), ChunkLabel (..), KnownChunk (..), KnownListChunk (..), labelRiff, peekChunkLabel) +import Data.ByteString.Short qualified as BSS +import Data.Default (Default (..)) +import Data.Foldable (toList) +import Data.Maybe (fromMaybe) +import Data.Primitive (sizeofByteArray) +import Data.Primitive.ByteArray (ByteArray) +import Data.Sequence (Seq (..)) +import Data.Sequence qualified as Seq +import Data.String (IsString) +import GHC.Generics (Generic) +import GHC.TypeLits (Nat, type (*), type (+)) + +labelWave, labelFmt, labelData, labelInfo, labelAdtl, labelCue, labelNote, labelLabl, labelLtxt, labelSmpl :: Label +labelWave = "WAVE" +labelFmt = "fmt " +labelData = "data" +labelInfo = "INFO" +labelAdtl = "adtl" +labelCue = "cue " +labelNote = "note" +labelLabl = "labl" +labelLtxt = "ltxt" +labelSmpl = "smpl" + +-- | A string NUL-padded to align to short width +newtype PaddedString = PaddedString {unPaddedString :: ShortByteString} + deriving stock (Show) + deriving newtype (Eq, IsString) + +instance Default PaddedString where + def = PaddedString BSS.empty + +mkPaddedString :: ShortByteString -> PaddedString +mkPaddedString sbs = + PaddedString $ + if not (BSS.null sbs) && BSS.last sbs == 0 + then BSS.init sbs + else sbs + +instance Binary PaddedString where + byteSize (PaddedString sbs) = padCount (ByteCount (BSS.length sbs)) + get = do + sbs <- getRemainingString + pure $! mkPaddedString sbs + put (PaddedString sbs) = do + putByteString sbs + let !usz = BSS.length sbs + unless (even usz) (putWord8 0) + +data WavFormatBody = WavFormatBody + { wfbFormatType :: !Word16LE + , wfbNumChannels :: !Word16LE + , wfbSampleRate :: !Word32LE + , wfbBitsPerSample :: !Word16LE + , wfbExtra :: !ShortByteString + } + deriving stock (Eq, Show) + +instance Default WavFormatBody where + def = WavFormatBody 1 1 44100 16 mempty + +isSupportedBPS :: Word16LE -> Bool +isSupportedBPS w = mod w 8 == 0 && w <= 64 + +isSupportedFmtExtraSize :: ByteCount -> Bool +isSupportedFmtExtraSize x = x == 0 || x == 2 || x == 24 + +instance Binary WavFormatBody where + byteSize wf = 16 + ByteCount (BSS.length (wfbExtra wf)) + get = do + formatType <- get + numChannels <- get + sampleRate <- get + bpsAvg <- get + bpsSlice <- get + bps <- get + unless (isSupportedBPS bps) (fail ("Bad bps: " ++ show bps)) + unless (bpsSlice == div bps 8 * numChannels) (fail ("Bad bps slice: " ++ show bpsSlice)) + unless (bpsAvg == sampleRate * fromIntegral bpsSlice) (fail ("Bad average bps: " ++ show bpsAvg)) + extra <- getRemainingString + let !extraLen = ByteCount (BSS.length extra) + unless (isSupportedFmtExtraSize extraLen) (fail ("Bad extra length: " ++ show extraLen)) + pure $! WavFormatBody formatType numChannels sampleRate bps extra + put (WavFormatBody fty nchan sr bps extra) = do + let !bpsSlice = div bps 8 * nchan + let !bpsAvg = sr * fromIntegral bpsSlice + put fty + put nchan + put sr + put bpsAvg + put bpsSlice + put bps + putByteString extra + +instance KnownLabel WavFormatBody where + knownLabel _ = labelFmt + +type WavFormatChunk = KnownChunk WavFormatBody + +newtype WavDataBody = WavDataBody {unWavDataBody :: ByteArray} + deriving stock (Show) + deriving newtype (Eq) + +instance KnownLabel WavDataBody where + knownLabel _ = labelData + +instance Binary WavDataBody where + byteSize (WavDataBody arr) = fromIntegral (sizeofByteArray arr) + get = fmap WavDataBody getRemainingByteArray + put (WavDataBody arr) = putByteArray arr + +type WavDataChunk = KnownChunk WavDataBody + +data WavInfoElem = WavInfoElem + { wieKey :: !Label + , wieVal :: !PaddedString + } + deriving stock (Eq, Show) + +instance Binary WavInfoElem where + byteSize (WavInfoElem _ val) = labelSize + countSize + byteSize val + get = do + key <- get + sz <- getChunkSizeLE + val <- getExact sz get + pure $! WavInfoElem key val + put (WavInfoElem key val) = do + put key + putChunkSizeLE (byteSize val) + put val + +instance KnownLabel WavInfoElem where + knownLabel _ = labelInfo + +type WavInfoChunk = KnownListChunk WavInfoElem + +-- NOTE: these are all the same for now, but ltxt has additional +-- structure that could be parsed out later +data WavAdtlData + = WavAdtlDataLabl !PaddedString + | WavAdtlDataNote !PaddedString + | WavAdtlDataLtxt !PaddedString + deriving stock (Eq, Show) + +byteSizeWavAdtlData :: WavAdtlData -> ByteCount +byteSizeWavAdtlData = \case + WavAdtlDataLabl bs -> byteSize bs + WavAdtlDataNote bs -> byteSize bs + WavAdtlDataLtxt bs -> byteSize bs + +wadString :: WavAdtlData -> ShortByteString +wadString = \case + WavAdtlDataLabl (PaddedString bs) -> bs + WavAdtlDataNote (PaddedString bs) -> bs + WavAdtlDataLtxt (PaddedString bs) -> bs + +data WavAdtlElem = WavAdtlElem + { waeCueId :: !Word32LE + , waeData :: !WavAdtlData + } + deriving stock (Eq, Show) + +instance Binary WavAdtlElem where + byteSize (WavAdtlElem _ dat) = 12 + byteSizeWavAdtlData dat + get = do + lab <- get + sz <- getChunkSizeLE + (cueId, bs) <- getExact sz $ do + cueId <- get + bs <- get + pure (cueId, bs) + dat <- + if + | lab == labelNote -> pure $! WavAdtlDataNote bs + | lab == labelLabl -> pure $! WavAdtlDataLabl bs + | lab == labelLtxt -> pure $! WavAdtlDataLtxt bs + | otherwise -> fail ("Unknown adtl sub-chunk: " ++ show lab) + pure $! WavAdtlElem cueId dat + put (WavAdtlElem cueId dat) = do + put $! case dat of + WavAdtlDataLabl _ -> labelLabl + WavAdtlDataNote _ -> labelNote + WavAdtlDataLtxt _ -> labelLtxt + putChunkSizeLE (4 + byteSizeWavAdtlData dat) + put cueId + case dat of + WavAdtlDataLabl bs -> put bs + WavAdtlDataNote bs -> put bs + WavAdtlDataLtxt bs -> put bs + +instance KnownLabel WavAdtlElem where + knownLabel _ = labelAdtl + +type WavAdtlChunk = KnownListChunk WavAdtlElem + +data WavCuePoint = WavCuePoint + { wcpPointId :: !Word32LE + , wcpPosition :: !Word32LE + , wcpChunkId :: !Word32LE + , wcpChunkStart :: !Word32LE + , wcpBlockStart :: !Word32LE + , wcpSampleStart :: !Word32LE + } + deriving stock (Eq, Show) + +type CuePointSize = 24 :: Nat + +cuePointSize :: ByteCount +cuePointSize = 24 + +instance StaticByteSized WavCuePoint where + type StaticSize WavCuePoint = CuePointSize + staticByteSize _ = cuePointSize + +instance Binary WavCuePoint where + byteSize _ = cuePointSize + get = do + wcpPointId <- get + wcpPosition <- get + wcpChunkId <- get + wcpChunkStart <- get + wcpBlockStart <- get + wcpSampleStart <- get + pure $! WavCuePoint {..} + put (WavCuePoint {..}) = do + put wcpPointId + put wcpPosition + put wcpChunkId + put wcpChunkStart + put wcpBlockStart + put wcpSampleStart + +newtype WavCueBody = WavCueBody + { wcbPoints :: Seq WavCuePoint + } + deriving stock (Eq, Show) + +instance Binary WavCueBody where + byteSize (WavCueBody points) = countSize + fromIntegral (Seq.length points) * cuePointSize + get = do + count <- get @Word32LE + points <- getSeq (fromIntegral count) get + pure $! WavCueBody points + put (WavCueBody points) = do + put (fromIntegral (Seq.length points) :: Word32LE) + putSeq put points + +instance KnownLabel WavCueBody where + knownLabel _ = labelCue + +type WavCueChunk = KnownChunk WavCueBody + +data WavSampleLoop = WavSampleLoop + { wslId :: !Word32LE + , wslType :: !Word32LE + , wslStart :: !Word32LE + , wslEnd :: !Word32LE + , wslFraction :: !Word32LE + , wslNumPlays :: !Word32LE + } + deriving stock (Eq, Show, Generic) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric WavSampleLoop) + +-- See https://www.recordingblogs.com/wiki/sample-chunk-of-a-wave-file +-- for explanation of sample period - for 44100 sr it's 0x00005893 +data WavSampleBody = WavSampleBody + { wsbManufacturer :: !Word32LE + , wsbProduct :: !Word32LE + , wsbSamplePeriod :: !Word32LE + , wsbMidiUnityNote :: !Word32LE + , wsbMidiPitchFrac :: !Word32LE + , wsbSmtpeFormat :: !Word32LE + , wsbSmtpeOffset :: !Word32LE + , wsbSampleLoops :: !(Seq WavSampleLoop) + } + deriving stock (Eq, Show) + +instance Binary WavSampleBody where + byteSize wsb = 32 + byteSizeFoldable (wsbSampleLoops wsb) + get = do + wsbManufacturer <- get + wsbProduct <- get + wsbSamplePeriod <- get + wsbMidiUnityNote <- get + wsbMidiPitchFrac <- get + wsbSmtpeFormat <- get + wsbSmtpeOffset <- get + numLoops <- get @Word32LE + wsbSampleLoops <- getSeq (fromIntegral numLoops) get + pure $! WavSampleBody {..} + put (WavSampleBody {..}) = do + put wsbManufacturer + put wsbProduct + put wsbSamplePeriod + put wsbMidiUnityNote + put wsbMidiPitchFrac + put wsbSmtpeFormat + put wsbSmtpeOffset + put @Word32LE (fromIntegral (Seq.length wsbSampleLoops)) + putSeq put wsbSampleLoops + +instance KnownLabel WavSampleBody where + knownLabel _ = labelSmpl + +type WavSampleChunk = KnownChunk WavSampleBody + +type WavUnparsedChunk = Chunk UnparsedBody + +data WavChunk + = WavChunkFormat !WavFormatChunk + | WavChunkData !WavDataChunk + | WavChunkInfo !WavInfoChunk + | WavChunkAdtl !WavAdtlChunk + | WavChunkCue !WavCueChunk + | WavChunkSample !WavSampleChunk + | WavChunkUnparsed !WavUnparsedChunk + deriving stock (Eq, Show) + +instance Binary WavChunk where + byteSize = \case + WavChunkFormat x -> byteSize x + WavChunkData x -> byteSize x + WavChunkInfo x -> byteSize x + WavChunkAdtl x -> byteSize x + WavChunkCue x -> byteSize x + WavChunkSample x -> byteSize x + WavChunkUnparsed x -> byteSize x + + get = do + chunkLabel <- peekChunkLabel + case chunkLabel of + ChunkLabelSingle label | label == labelFmt -> fmap WavChunkFormat get + ChunkLabelSingle label | label == labelData -> fmap WavChunkData get + ChunkLabelList label | label == labelInfo -> fmap WavChunkInfo get + ChunkLabelList label | label == labelAdtl -> fmap WavChunkAdtl get + ChunkLabelSingle label | label == labelCue -> fmap WavChunkCue get + ChunkLabelSingle label | label == labelSmpl -> fmap WavChunkSample get + _ -> fmap WavChunkUnparsed get + put = \case + WavChunkFormat x -> put x + WavChunkData x -> put x + WavChunkInfo x -> put x + WavChunkAdtl x -> put x + WavChunkCue x -> put x + WavChunkSample x -> put x + WavChunkUnparsed x -> put x + +newtype WavHeader = WavHeader + { wavHeaderRemainingSize :: ByteCount + } + deriving stock (Show) + deriving newtype (Eq) + +type WavHeaderSize = 2 * LabelSize + CountSize + +wavHeaderSize :: ByteCount +wavHeaderSize = 2 * labelSize + countSize + +instance StaticByteSized WavHeader where + type StaticSize WavHeader = WavHeaderSize + staticByteSize _ = wavHeaderSize + +instance Binary WavHeader where + get = do + getExpectLabel labelRiff + sz <- getChunkSizeLE + getExpectLabel labelWave + pure $! WavHeader (sz - labelSize) + put (WavHeader remSz) = do + put labelRiff + putChunkSizeLE (remSz + labelSize) + put labelWave + +newtype Wav = Wav + { wavChunks :: Seq WavChunk + } + deriving stock (Eq, Show) + +instance Binary Wav where + byteSize (Wav chunks) = wavHeaderSize + byteSizeFoldable chunks + get = do + WavHeader remSz <- get + chunks <- getExact remSz (getRemainingSeq get) + pure $! Wav chunks + put (Wav chunks) = do + let !remSz = byteSizeFoldable chunks + put (WavHeader remSz) + putSeq put chunks + +lookupWavChunk :: (WavChunk -> Bool) -> Wav -> Maybe WavChunk +lookupWavChunk p (Wav chunks) = fmap (Seq.index chunks) (Seq.findIndexL p chunks) + +bindWavChunk :: (WavChunk -> Seq WavChunk) -> Wav -> Wav +bindWavChunk f (Wav chunks) = Wav (chunks >>= f) + +lookupWavFormatChunk :: Wav -> Maybe WavFormatChunk +lookupWavFormatChunk w = + case lookupWavChunk (\case WavChunkFormat _ -> True; _ -> False) w of + Just (WavChunkFormat x) -> Just x + _ -> Nothing + +lookupWavDataChunk :: Wav -> Maybe WavDataChunk +lookupWavDataChunk w = + case lookupWavChunk (\case WavChunkData _ -> True; _ -> False) w of + Just (WavChunkData x) -> Just x + _ -> Nothing + +lookupWavCueChunk :: Wav -> Maybe WavCueChunk +lookupWavCueChunk w = + case lookupWavChunk (\case WavChunkCue _ -> True; _ -> False) w of + Just (WavChunkCue x) -> Just x + _ -> Nothing + +lookupWavAdtlChunk :: Wav -> Maybe WavAdtlChunk +lookupWavAdtlChunk w = + case lookupWavChunk (\case WavChunkAdtl _ -> True; _ -> False) w of + Just (WavChunkAdtl x) -> Just x + _ -> Nothing + +wavToPcmContainer :: Wav -> Either ConvertErr PcmContainer +wavToPcmContainer wav = do + KnownChunk fmtBody <- guardChunk "format" (lookupWavFormatChunk wav) + KnownChunk (WavDataBody arr) <- guardChunk "data" (lookupWavDataChunk wav) + let !nc = fromIntegral (wfbNumChannels fmtBody) + !bps = fromIntegral (wfbBitsPerSample fmtBody) + !sr = fromIntegral (wfbSampleRate fmtBody) + !ns = SampleCount (div (sizeofByteArray arr) (nc * div bps 8)) + !meta = PcmMeta nc ns bps sr + pure $! PcmContainer meta arr + +wavFromPcmContainer :: PcmContainer -> Wav +wavFromPcmContainer (PcmContainer (PcmMeta {..}) arr) = + let fmtBody = + WavFormatBody + { wfbFormatType = 1 + , wfbNumChannels = fromIntegral pmNumChannels + , wfbSampleRate = fromIntegral pmSampleRate + , wfbBitsPerSample = fromIntegral pmBitsPerSample + , wfbExtra = mempty + } + fmtChunk = WavChunkFormat (KnownChunk fmtBody) + dataChunk = WavChunkData (KnownChunk (WavDataBody arr)) + in Wav (Seq.fromList [fmtChunk, dataChunk]) + +wcpFromMarker :: Int -> SimpleMarker -> WavCuePoint +wcpFromMarker ix sm = WavCuePoint (fromIntegral ix) (fromIntegral (smPosition sm)) 0 0 0 (fromIntegral (smPosition sm)) + +waeFromMarker :: Int -> SimpleMarker -> WavAdtlElem +waeFromMarker ix sm = WavAdtlElem (fromIntegral ix) (WavAdtlDataLabl (mkPaddedString (smName sm))) + +wavUseMarkers :: Seq SimpleMarker -> (WavCueChunk, WavAdtlChunk) +wavUseMarkers marks = + let wcps = Seq.mapWithIndex wcpFromMarker marks + wcc = KnownChunk (WavCueBody wcps) + waes = Seq.mapWithIndex waeFromMarker marks + wac = KnownListChunk waes + in (wcc, wac) + +wavUseLoopPoints :: Int -> Int -> LoopMarkPoints -> WavSampleChunk +wavUseLoopPoints sr note (LoopMarks _ (startId, loopStart) (_, loopEnd) _) = + let wsbManufacturer = 0 + wsbProduct = 0 + wsbSamplePeriod = fromIntegral (div 1000000000 sr) + wsbMidiUnityNote = fromIntegral note + wsbMidiPitchFrac = 0 + wsbSmtpeFormat = 0 + wsbSmtpeOffset = 0 + wslId = fromIntegral startId + wslType = 0 + wslStart = fromIntegral (smPosition loopStart) + wslEnd = fromIntegral (smPosition loopEnd) + wslFraction = 0 + wslNumPlays = 0 + wsl = WavSampleLoop {..} + wsbSampleLoops = Seq.singleton wsl + wsb = WavSampleBody {..} + in KnownChunk wsb + +wavAddChunks :: Seq WavChunk -> Wav -> Wav +wavAddChunks chunks wav = wav {wavChunks = wavChunks wav <> chunks} + +wavGatherMarkers :: Wav -> Seq SimpleMarker +wavGatherMarkers wav = fromMaybe Seq.empty $ do + KnownChunk cueBody <- lookupWavCueChunk wav + KnownListChunk adtlElems <- lookupWavAdtlChunk wav + let !cues = fmap (\wcp -> (wcpPointId wcp, wcpSampleStart wcp)) (toList (wcbPoints cueBody)) + !names = fmap (\wae -> (waeCueId wae, wadString (waeData wae))) (toList adtlElems) + !marks = Seq.fromList $ do + (pid, ss) <- cues + case lookup pid names of + Nothing -> [] + Just nm -> [SimpleMarker nm (unWord32LE ss)] + pure $! dedupeSimpleMarkers marks diff --git a/src/Dahdit/Audio/Wav/Simple.hs b/src/Dahdit/Audio/Wav/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Audio/Wav/Simple.hs @@ -0,0 +1,116 @@ +-- | Interface semi-compatible with the WAVE library (but more efficient) +module Dahdit.Audio.Wav.Simple + ( WAVE (..) + , WAVEHeader (..) + , WAVESample + , WAVESamples (..) + , toPcmContainer + , toComplex + , fromComplex + , getWAVEFile + , putWAVEFile + ) +where + +import Control.Exception (throwIO) +import Control.Monad (unless, (>=>)) +import Dahdit.Audio.Common (ConvertErr (..), guardChunk, rethrow) +import Dahdit.Audio.Convert (convertMod) +import Dahdit.Audio.Dsp (DspErr (..), PcmContainer (..), PcmMeta (..), SampleCount (..), changeBitDepth) +import Dahdit.Audio.Riff (KnownChunk (..)) +import Dahdit.Audio.Wav + ( Wav (..) + , WavChunk (..) + , WavDataBody (..) + , WavFormatBody (..) + , lookupWavFormatChunk + , wavToPcmContainer + ) +import Dahdit.Iface (decodeFileEnd, encodeFile) +import Dahdit.Nums (Int16LE, Int24LE) +import Dahdit.Proxy (proxyForF) +import Dahdit.Sizes (ByteCount (..), staticByteSize) +import Data.Int (Int32) +import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray) +import Data.Primitive.PrimArray (PrimArray (..), sizeofPrimArray) +import Data.Sequence (Seq (..)) + +data WAVEHeader = WAVEHeader + { waveNumChannels :: Int + , waveFrameRate :: Int + , waveBitsPerSample :: Int + , waveFrames :: Maybe Int + } + deriving stock (Eq, Show) + +type WAVESample = Int32 + +newtype WAVESamples = WAVESamples {unWAVESamples :: PrimArray Int32} + deriving stock (Eq, Show) + +data WAVE = WAVE + { waveHeader :: WAVEHeader + , waveSamples :: WAVESamples + } + deriving stock (Eq, Show) + +toPcmContainer :: WAVE -> Either ConvertErr PcmContainer +toPcmContainer (WAVE hdr (WAVESamples arr@(PrimArray ba))) = do + let elemSize = staticByteSize (proxyForF arr) + nc = waveNumChannels hdr + ns = div (sizeofPrimArray arr) nc + bps = unByteCount elemSize * 8 + sr = waveFrameRate hdr + extraElems = rem (sizeofPrimArray arr) nc + pm = PcmMeta nc (SampleCount ns) bps sr + unless (extraElems == 0) (Left (ConvertErrDsp DspErrBadElemSize)) + pure (PcmContainer pm (ByteArray ba)) + +toComplex :: WAVE -> Either ConvertErr Wav +toComplex wave0@(WAVE hdr _) = do + pc0 <- toPcmContainer wave0 + let bps = waveBitsPerSample hdr + pc1 <- case bps of + 16 -> convertMod (changeBitDepth @Int32 @Int16LE 32 16) pc0 + 24 -> convertMod (changeBitDepth @Int32 @Int24LE 32 24) pc0 + 32 -> pure pc0 + y -> Left (ConvertErrBadBps y) + let samps1 = pcData pc1 + wfb = + WavFormatBody + { wfbFormatType = 1 + , wfbNumChannels = fromIntegral (waveNumChannels hdr) + , wfbSampleRate = fromIntegral (waveFrameRate hdr) + , wfbBitsPerSample = fromIntegral bps + , wfbExtra = mempty + } + headerChunk = WavChunkFormat (KnownChunk wfb) + dataChunk = WavChunkData (KnownChunk (WavDataBody samps1)) + pure (Wav (headerChunk :<| dataChunk :<| Empty)) + +fromComplex :: Wav -> Either ConvertErr WAVE +fromComplex wav0 = do + pc0 <- wavToPcmContainer wav0 + let bps = pmBitsPerSample (pcMeta pc0) + pc1 <- case bps of + 16 -> convertMod (changeBitDepth @Int16LE @Int32 16 32) pc0 + 24 -> convertMod (changeBitDepth @Int24LE @Int32 24 32) pc0 + 32 -> pure pc0 + y -> Left (ConvertErrBadBps y) + KnownChunk wfb <- guardChunk "format" (lookupWavFormatChunk wav0) + let !samps@(ByteArray ba) = pcData pc1 + hdr = + WAVEHeader + { waveNumChannels = fromIntegral (wfbNumChannels wfb) + , waveFrameRate = fromIntegral (wfbSampleRate wfb) + , waveBitsPerSample = bps + , waveFrames = Just (div (sizeofByteArray samps) 4) + } + + pure (WAVE hdr (WAVESamples (PrimArray ba))) + +getWAVEFile :: FilePath -> IO WAVE +getWAVEFile = decodeFileEnd >=> rethrow . fst >=> rethrow . fromComplex + +putWAVEFile :: FilePath -> WAVE -> IO () +putWAVEFile fp wave = either throwIO (`encodeFile` fp) (toComplex wave) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Exception (Exception, throwIO) +import Control.Monad ((>=>)) +import Dahdit + ( Binary (..) + , ByteCount + , ElemCount (..) + , Get + , Int16LE (..) + , ShortByteString + , StaticByteSized (..) + , Word8 + , byteSize + , decode + , decodeFile + , decodeFileEnd + , encode + , encodeFile + , getExact + , getSkip + , getTarget + ) +import Dahdit.Audio.Aiff (Aiff (..), AiffDataBody (..), lookupAiffDataChunk) +import Dahdit.Audio.Aiff qualified as Aiff +import Dahdit.Audio.Common + ( LoopMarks (..) + , UnparsedBody (..) + , chunkHeaderSize + , defaultLoopMarkNames + , defaultNoteNumber + , defineLoopMarks + , getChunkSizeLE + , getExpectLabel + , guardChunk + , rethrow + ) +import Dahdit.Audio.Convert + ( Neutral (..) + , aiffToNeutral + , neutralMono + , neutralToSampleWav + , neutralToWav + , wavToNeutral + ) +import Dahdit.Audio.Dsp (ModMeta (..), PcmContainer (..), linearCrossFade, monoFromLeft, runMod) +import Dahdit.Audio.Riff (Chunk (..), KnownChunk (..), KnownListChunk (..), KnownOptChunk (..), labelRiff) +import Dahdit.Audio.Sfont + ( Bag + , Gen + , InfoChunk (..) + , Inst + , Mod + , PdtaChunk (..) + , Phdr + , Sdta (..) + , SdtaChunk (..) + , Sfont (..) + , Shdr + , labelSfbk + ) +import Dahdit.Audio.Wav + ( Wav (..) + , WavAdtlChunk + , WavAdtlData (..) + , WavAdtlElem (..) + , WavChunk (..) + , WavDataBody (..) + , WavFormatBody (..) + , WavFormatChunk + , WavHeader (..) + , WavInfoElem (..) + , lookupWavDataChunk + , lookupWavFormatChunk + , wavToPcmContainer + ) +import Dahdit.Audio.Wav.Simple qualified as DAWS +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Short qualified as BSS +import Data.Foldable (for_, toList) +import Data.Int (Int8) +import Data.Maybe (fromMaybe) +import Data.Primitive.ByteArray (indexByteArray, sizeofByteArray) +import Data.Primitive.PrimArray (primArrayFromList, sizeofPrimArray) +import Data.Proxy (Proxy (..)) +import Data.Sequence qualified as Seq +import Test.Daytripper (daytripperMain) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +drumFmtOffset :: ByteCount +drumFmtOffset = 12 + +drumDataOffset :: ByteCount +drumDataOffset = 36 + +drumPostDataOffset :: ByteCount +drumPostDataOffset = 497816 + +drumFmtChunk :: WavFormatChunk +drumFmtChunk = KnownChunk (WavFormatBody 1 2 44100 16 mempty) + +drumFileSize :: ByteCount +drumFileSize = 497896 + +drumEndOffset :: ByteCount +drumEndOffset = drumFileSize + 8 + +drumHeader :: WavHeader +drumHeader = WavHeader (drumFileSize - 4) + +drumDataLen :: ElemCount +drumDataLen = 248886 + +readShort :: FilePath -> IO ShortByteString +readShort = fmap (BSS.toShort . BSL.toStrict) . BSL.readFile + +throwFirst :: (Exception e) => (Either e a, b) -> IO (a, b) +throwFirst (ea, b) = + case ea of + Left e -> throwIO e + Right a -> pure (a, b) + +decodeThrow :: (Binary a) => ShortByteString -> IO (a, ByteCount) +decodeThrow = decode >=> throwFirst + +getTargetThrow :: Get a -> ShortByteString -> IO (a, ByteCount) +getTargetThrow g z = getTarget g z >>= throwFirst + +decodeFileThrow :: (Binary a) => FilePath -> IO (a, ByteCount) +decodeFileThrow = decodeFile >=> throwFirst + +testWavSerde :: TestTree +testWavSerde = testCase "serde" $ do + -- KnownChunk + byteSize drumFmtChunk @?= 24 + fmtBs <- encode drumFmtChunk + (fmt, fmtSz) <- decodeThrow fmtBs + byteSize fmt @?= fmtSz + fmt @?= drumFmtChunk + -- Odd and even unparsed chunks + let unpSz = 10 + unpOdd = Chunk "FOOB" (UnparsedBody "A") + unpEven = Chunk "FOOB" (UnparsedBody "AB") + byteSize unpOdd @?= unpSz + byteSize unpEven @?= unpSz + unpOddBs <- encode unpOdd + (unpOdd', unpOddSz) <- decodeThrow unpOddBs + byteSize unpOdd' @?= unpOddSz + unpOdd' @?= unpOdd + unpEvenBs <- encode unpEven + (unpEven', unpEvenSz) <- decodeThrow unpEvenBs + byteSize unpEven' @?= unpEvenSz + unpEven' @?= unpEven + -- Adtl chunks + let adtlChunkEven = KnownListChunk (Seq.singleton (WavAdtlElem 42 (WavAdtlDataNote "hi"))) + assertReparses @WavAdtlChunk adtlChunkEven + let adtlChunkOdd = KnownListChunk (Seq.singleton (WavAdtlElem 42 (WavAdtlDataNote "h"))) + assertReparses @WavAdtlChunk adtlChunkOdd + +testWavHeader :: TestTree +testWavHeader = testCase "header" $ do + bs <- readShort "testdata/drums.wav" + (header, bc) <- decodeThrow bs + header @?= drumHeader + bc @?= drumFmtOffset + +testWavData :: TestTree +testWavData = testCase "data" $ do + bs <- readShort "testdata/drums.wav" + (arr, _) <- flip getTargetThrow bs $ do + getSkip drumDataOffset + chunk <- get + case chunk of + WavChunkData (KnownChunk (WavDataBody arr)) -> pure arr + _ -> fail "expected data" + fromIntegral (sizeofByteArray arr) @?= drumDataLen * 2 -- x2 for 2-byte samples + +testWavInfo :: TestTree +testWavInfo = testCase "info" $ do + bs <- readShort "testdata/drums.wav" + (info, _) <- flip getTargetThrow bs $ do + getSkip drumPostDataOffset + chunk <- get + case chunk of + WavChunkInfo (KnownListChunk info) -> pure info + _ -> fail "expected info" + info @?= Seq.fromList [WavInfoElem "IART" "freewavesamples.com"] + +testWavWhole :: TestTree +testWavWhole = testCase "whole" $ do + bs <- readShort "testdata/drums.wav" + (wav, _) <- decodeThrow bs + fmtChunk <- rethrow (guardChunk "format" (lookupWavFormatChunk wav)) + fmtChunk @?= drumFmtChunk + KnownChunk (WavDataBody arr) <- rethrow (guardChunk "data" (lookupWavDataChunk wav)) + fromIntegral (sizeofByteArray arr) @?= drumDataLen * 2 -- x2 for 2-byte samples + Seq.length (wavChunks wav) @?= 4 + +testWavWrite :: TestTree +testWavWrite = testCase "write" $ do + bs <- readShort "testdata/drums.wav" + (wav, bc) <- decodeThrow bs + byteSize wav @?= bc + for_ (wavChunks wav) assertReparses + bs' <- encode wav + bs' @?= bs + +testWavWrite2 :: TestTree +testWavWrite2 = testCase "write 2" $ do + bs <- readShort "testdata/DX-EPiano1-C1.wav" + (wav, bc) <- decodeThrow bs + byteSize wav @?= bc + for_ (wavChunks wav) assertReparses + bs' <- encode wav + bs' @?= bs + +testWav :: TestTree +testWav = testGroup "wav" [testWavSerde, testWavHeader, testWavData, testWavInfo, testWavWhole, testWavWrite, testWavWrite2] + +testAiff :: TestTree +testAiff = testCase "aiff" $ do + bs <- readShort "testdata/M1F1-int16s-AFsp.aif" + (aiff, bc) <- decodeThrow bs + byteSize aiff @?= bc + bc @?= fromIntegral (BSS.length bs) + for_ (aiffChunks aiff) assertReparses + bs' <- encode aiff + fromIntegral (BSS.length bs') @?= bc + bs' @?= bs + +testAiff2 :: TestTree +testAiff2 = testCase "aiff2" $ do + bs <- readShort "testdata/DX-EPiano1-C1.aif" + (aiff :: Aiff, _) <- decodeThrow bs + bs' <- encode aiff + bs' @?= bs + +testSfontWhole :: TestTree +testSfontWhole = testCase "whole" $ do + bs <- readShort "testdata/timpani.sf2" + ( Sfont (InfoChunk (KnownListChunk infos)) (SdtaChunk (KnownOptChunk maySdta)) (PdtaChunk (KnownListChunk pdtaBlocks)) + , _ + ) <- + decodeThrow bs + Seq.length infos @?= 5 + case maySdta of + Nothing -> fail "Missing sdta" + Just sdta -> do + sizeofPrimArray (sdtaHighBits sdta) @?= 1365026 + sdtaLowBits sdta @?= Nothing + Seq.length pdtaBlocks @?= 9 + +testSfontWrite :: TestTree +testSfontWrite = testCase "write" $ do + bs <- readShort "testdata/timpani.sf2" + (sfont, _) <- decodeThrow @Sfont bs + bs' <- encode sfont + bs' @?= bs + +testSfontManual :: TestTree +testSfontManual = testCase "manual" $ do + bs <- readShort "testdata/timpani.sf2" + ((info, sdta, pdta), _) <- flip getTargetThrow bs $ do + getExpectLabel labelRiff + chunkSize <- getChunkSizeLE + getExact chunkSize $ do + getExpectLabel labelSfbk + info <- get @InfoChunk + sdta <- get @SdtaChunk + pdta <- get @PdtaChunk + pure (info, sdta, pdta) + let expecInfoSize = 124 + chunkHeaderSize + expecSdtaSize = 2730064 + chunkHeaderSize + expecPdtaSize = 3010 + chunkHeaderSize + byteSize info @?= expecInfoSize + byteSize sdta @?= expecSdtaSize + byteSize pdta @?= expecPdtaSize + infoBs <- encode info + BSS.length infoBs @?= fromIntegral expecInfoSize + sdtaBs <- encode sdta + BSS.length sdtaBs @?= fromIntegral expecSdtaSize + pdtaBs <- encode pdta + BSS.length pdtaBs @?= fromIntegral expecPdtaSize + +testSfontSizes :: TestTree +testSfontSizes = testCase "sizes" $ do + staticByteSize (Proxy :: Proxy Phdr) @?= 38 + staticByteSize (Proxy :: Proxy Bag) @?= 4 + staticByteSize (Proxy :: Proxy Mod) @?= 10 + staticByteSize (Proxy :: Proxy Gen) @?= 4 + staticByteSize (Proxy :: Proxy Inst) @?= 22 + staticByteSize (Proxy :: Proxy Shdr) @?= 46 + +testSfont :: TestTree +testSfont = testGroup "sfont" [testSfontSizes, testSfontWhole, testSfontWrite, testSfontManual] + +assertReparses :: (Binary a, Eq a, Show a) => a -> IO () +assertReparses a = do + bs <- encode a + (a', bc) <- decodeThrow bs + byteSize a' @?= bc + a' @?= a + +testConvertDx :: TestTree +testConvertDx = testCase "DX" $ do + bs <- readShort "testdata/DX-EPiano1-C1.aif" + (aif, _) <- decodeThrow bs + ne <- rethrow (aiffToNeutral 44100 aif (Just defaultLoopMarkNames)) + -- Test that a standard translation of the wav works + let !wav = neutralToWav defaultNoteNumber ne + pc <- rethrow (wavToPcmContainer wav) + pc @?= neCon ne + assertReparses wav + xne <- rethrow (wavToNeutral wav (Just defaultLoopMarkNames)) + xne @?= ne + -- Test that the sample wav works + let !width = 2500 -- double this is 0.1s of total fade + swav <- rethrow (neutralToSampleWav width defaultNoteNumber ne) + assertReparses swav + pure () + +aifSamples :: Aiff -> [Word8] +aifSamples aif = + let Aiff.KnownChunk (AiffDataBody _ _ wavData) = fromMaybe (error "no data") (lookupAiffDataChunk aif) + !sz = sizeofByteArray wavData + in fmap (indexByteArray wavData) [0 .. sz - 1] + +wavSamples :: Wav -> [Word8] +wavSamples wav = + let KnownChunk (WavDataBody wavData) = fromMaybe (error "no data") (lookupWavDataChunk wav) + !sz = sizeofByteArray wavData + in fmap (indexByteArray wavData) [0 .. sz - 1] + +neutralSamples :: Neutral -> [Word8] +neutralSamples ne = + let !wavData = pcData (neCon ne) + !sz = sizeofByteArray wavData + in fmap (indexByteArray wavData) [0 .. sz - 1] + +wavFmt :: Wav -> WavFormatBody +wavFmt wav = fmtBody + where + KnownChunk fmtBody = fromMaybe (error "no format") (lookupWavFormatChunk wav) + +takeN :: Int -> [Word8] -> [Word8] +takeN n xs = let f = take n in f xs ++ reverse (f (reverse xs)) + +evenShorts :: [Word8] -> [Word8] +evenShorts (x : y : zs) = x : y : oddShorts zs +evenShorts _ = [] + +oddShorts :: [Word8] -> [Word8] +oddShorts (_ : _ : zs) = evenShorts zs +oddShorts _ = [] + +takeSome :: [Word8] -> [Word8] +takeSome = takeN 10 + +takeSomeEvens :: [Word8] -> [Word8] +takeSomeEvens = evenShorts . takeN 20 + +tryAifToWav :: Int -> String -> IO () +tryAifToWav channels variant = do + (aif, _) <- decodeFileThrow ("testdata/sin_" ++ variant ++ ".aifc") + (wav, _) <- decodeFileThrow ("testdata/sin_" ++ variant ++ ".wav") + ne <- rethrow (aiffToNeutral 44100 aif Nothing) + let !conv = neutralToWav defaultNoteNumber ne + let !aifPart = takeSome (aifSamples aif) + let !wavPart = takeSome (wavSamples wav) + wavPart @?= aifPart + let !convPart = takeSome (wavSamples conv) + convPart @?= aifPart + -- conv and wav will be different bc of addl chunks like cue + -- but their formats will be the same + let !convFx = wavFmt conv + wfbNumChannels convFx @?= fromIntegral channels + let !wavFx = wavFmt wav + convFx @?= wavFx + +tryWavMono :: IO () +tryWavMono = do + -- Read stereo + mono versions of same wav, assert their samples are correct + (wavStereo, _) <- decodeFileThrow "testdata/sin_stereo.wav" + (wavMono, _) <- decodeFileThrow "testdata/sin_mono.wav" + let !leftStereoPart = takeSomeEvens (wavSamples wavStereo) + let !monoPart = takeSome (wavSamples wavMono) + monoPart @?= leftStereoPart + -- Now make the stereo wav mono and assert the same + neExtract <- rethrow (wavToNeutral wavStereo Nothing >>= neutralMono) + let !extractPart = takeSome (neutralSamples neExtract) + extractPart @?= monoPart + +testConvertSin :: TestTree +testConvertSin = testCase "sin" $ do + tryAifToWav 1 "mono" + tryAifToWav 2 "stereo" + tryWavMono + +testConvertLoop :: TestTree +testConvertLoop = testCase "loop" $ do + (wav, _) <- decodeFileThrow "testdata/sin_mono.wav" + con <- rethrow (wavToPcmContainer wav) + let mkLoopMarks = defineLoopMarks @Int defaultLoopMarkNames . fmap (* 6000) + !loopMarks = mkLoopMarks (LoopMarks 1 2 3 4) + !marks = Seq.fromList (fmap snd (toList loopMarks)) + let !ne = Neutral {neCon = con, neLoopMarks = Just loopMarks, neMarks = marks} + -- Convert and write out for inspection + let !fullWav = neutralToWav defaultNoteNumber ne + encodeFile fullWav "testoutput/sin_mono_full.wav" + sampleWav <- rethrow (neutralToSampleWav 2500 defaultNoteNumber ne) + encodeFile sampleWav "testoutput/sin_mono_sample.wav" + -- Test full wav marks + fullNe <- rethrow (wavToNeutral fullWav (Just defaultLoopMarkNames)) + let !actualFullLoopMarks = neLoopMarks fullNe + actualFullLoopMarks @?= Just loopMarks + -- Test sample wav marks + let !expectedSampleLoopMarks = mkLoopMarks (LoopMarks 0 1 2 2) + sampleNe <- rethrow (wavToNeutral sampleWav (Just defaultLoopMarkNames)) + let !actualSampleLoopMarks = neLoopMarks sampleNe + actualSampleLoopMarks @?= Just expectedSampleLoopMarks + +testConvertFade :: TestTree +testConvertFade = testCase "fade" $ do + (wav, _) <- decodeFileThrow "testdata/fadeout_post.wav" + con <- rethrow (wavToPcmContainer wav) + let mkLoopMarks = defineLoopMarks @Int defaultLoopMarkNames . fmap (* 4410) + !loopMarks = mkLoopMarks (LoopMarks 0 3 6 10) + !marks = Seq.fromList (fmap snd (toList loopMarks)) + let !ne = Neutral {neCon = con, neLoopMarks = Just loopMarks, neMarks = marks} + -- Convert and write out for inspection + let !fullWav = neutralToWav defaultNoteNumber ne + encodeFile fullWav "testoutput/fadeout_full.wav" + sampleWav <- rethrow (neutralToSampleWav 1000 defaultNoteNumber ne) + encodeFile sampleWav "testoutput/fadeout_sample.wav" + +testConvertDxFade :: TestTree +testConvertDxFade = testCase "dx fade" $ do + (wav, _) <- decodeFileThrow "testdata/DX-EPiano1-C1.wav" + ne <- rethrow (wavToNeutral wav (Just defaultLoopMarkNames)) + neMon <- rethrow (neutralMono ne) + -- Convert and write out for inspection + let !fullWav = neutralToWav defaultNoteNumber neMon + encodeFile fullWav "testoutput/dx_full.wav" + sampleWav <- rethrow (neutralToSampleWav 2500 defaultNoteNumber neMon) + encodeFile sampleWav "testoutput/dx_sample.wav" + +testConvert :: TestTree +testConvert = testGroup "convert" [testConvertDx, testConvertSin, testConvertLoop, testConvertFade, testConvertDxFade] + +testDspMono :: TestTree +testDspMono = testCase "mono" $ do + let !larr1 = primArrayFromList @Int16LE [0, 1, 2, 3, 4, 5] + !larr2 = primArrayFromList @Int16LE [0, 2, 4] + !mm1 = ModMeta {mmNumChannels = 2, mmBitsPerSample = 16, mmSampleRate = 44100} + !mm2 = mm1 {mmNumChannels = 1} + (!mmx, !larrx) <- rethrow (runMod monoFromLeft mm1 larr1) + mmx @?= mm2 + larrx @?= larr2 + +testDspFadeOne :: TestTree +testDspFadeOne = testCase "fade one" $ do + let !larr1 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1] + -- ^ ^ + !width = 1 + !loopStart = 7 + !loopEnd = 15 + !larr2 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 5, 5, 3, 5, 1, 1, 1, 1, 1, 5, 3, 1] + -- ^ ^ + !mm = ModMeta {mmNumChannels = 1, mmBitsPerSample = 8, mmSampleRate = 44100} + (!mmx, !larrx) <- rethrow (runMod (linearCrossFade width loopStart loopEnd) mm larr1) + mmx @?= mm + larrx @?= larr2 + +testDspFadeSome :: TestTree +testDspFadeSome = testCase "fade some" $ do + let !larr1 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1] + !width = 3 + !loopStart = 7 + !loopEnd = 15 + !larr2 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 4, 3, 3, 3, 1, 1, 1, 5, 4, 3, 3, 2] + !mm = ModMeta {mmNumChannels = 1, mmBitsPerSample = 8, mmSampleRate = 44100} + (!mmx, !larrx) <- rethrow (runMod (linearCrossFade width loopStart loopEnd) mm larr1) + mmx @?= mm + larrx @?= larr2 + +testDspFadeWider :: TestTree +testDspFadeWider = testCase "fade wider" $ do + let !larr1 = primArrayFromList @Int16LE [5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1] + !width = 3 + !loopStart = 7 + !loopEnd = 15 + !larr2 = primArrayFromList @Int16LE [5, 5, 5, 5, 5, 4, 3, 3, 3, 1, 1, 1, 5, 4, 3, 3, 2] + !mm = ModMeta {mmNumChannels = 1, mmBitsPerSample = 16, mmSampleRate = 44100} + (!mmx, !larrx) <- rethrow (runMod (linearCrossFade width loopStart loopEnd) mm larr1) + mmx @?= mm + larrx @?= larr2 + +testDsp :: TestTree +testDsp = testGroup "dsp" [testDspMono, testDspFadeOne, testDspFadeSome, testDspFadeWider] + +testWavSimple :: TestTree +testWavSimple = testCase "wav simple" $ do + wav <- rethrow . fst =<< decodeFileEnd "testdata/drums.wav" + pcBefore <- rethrow (wavToPcmContainer wav) + simple <- rethrow (DAWS.fromComplex wav) + complex <- rethrow (DAWS.toComplex simple) + pcAfter <- rethrow (wavToPcmContainer complex) + -- There is more to check, but a good approximation is that + -- the wavs are equal as PCM containers before and after converting to + -- the simplified representation. + pcAfter @?= pcBefore + +testDahditAudio :: TestTree +testDahditAudio = + testGroup + "dahdit-audio" + [testWav, testAiff, testAiff2, testSfont, testConvert, testDsp, testWavSimple] + +main :: IO () +main = daytripperMain (const testDahditAudio)