More modularization of data processing

library/VaporTrail.hs

@@ -2,190 +2,40 @@
 module VaporTrail (main) where
 
 import Control.Monad
-import Data.Bits
 import Data.ByteString.Builder
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as B
-import Data.Complex
 import Data.Foldable
-import Data.Functor.Identity
-import Data.Int
-import Data.List
-import qualified Data.List.NonEmpty as NE
-import Data.List.Split
-import qualified Data.Machine as Machine
 import Data.Machine hiding (fold, zipWith)
-import Data.Machine.Group
-import Data.Machine.Runner
-import Data.Maybe
-import Data.Semigroup
 import Data.Word
-import Debug.Trace
 import GHC.Float (float2Double)
 import System.Environment
-import qualified VaporTrail.Filter.Basic as Filter.Basic
-import VaporTrail.Filter.Fourier
-
-
-runFilter :: (Float -> Int -> Process Float Float) -> Float -> [Float] -> [Float]
-runFilter m hz xs = run (m hz sampleRate <~ source xs)
-
-lowPass6db :: Float -> [Float] -> [Float]
-lowPass6db = runFilter Filter.Basic.lowPass6db
-
-lowPass12db ::Float -> [Float] -> [Float]
-lowPass12db = runFilter Filter.Basic.lowPass12db
-
-lowPass24db ::Float -> [Float] -> [Float]
-lowPass24db = runFilter Filter.Basic.lowPass24db
-
-highPass6db ::Float -> [Float] -> [Float]
-highPass6db = runFilter Filter.Basic.highPass6db
-
-highPass12db ::Float -> [Float] -> [Float]
-highPass12db = runFilter Filter.Basic.highPass12db
-
-highPass24db ::Float -> [Float] -> [Float]
-highPass24db = runFilter Filter.Basic.highPass24db
-
-bandPass6db ::Float -> [Float] -> [Float]
-bandPass6db = runFilter Filter.Basic.bandPass6db
-
-bandPass12db ::Float -> [Float] -> [Float]
-bandPass12db = runFilter Filter.Basic.bandPass12db
-
-bandPass24db ::Float -> [Float] -> [Float]
-bandPass24db = runFilter Filter.Basic.bandPass24db
-
-
-
-data TWord = Sync | One | Zero | Empty deriving (Eq,Read,Show)
-
-tAmp :: Fractional a => TWord -> a
-tAmp Sync = 5 / 5
-tAmp One = 3 / 5
-tAmp Zero = 2 / 5
-tAmp Empty = 0
+import VaporTrail.Filter.SignalLock
+import VaporTrail.Codec.Type
+import VaporTrail.Codec.UCode
+import VaporTrail.Codec.PCM
+import VaporTrail.Codec.Bits
 
+sampleRate :: Int
 sampleRate = 48000
 
+dataRate :: Int
 dataRate = 2000
 
--- TODO factor this out
-lockSignal :: Process Float Float
-lockSignal =
-  let dftSize = 192
-      dftSizeF = fromIntegral dftSize
-      lockChunk = do
-        c <- replicateM dftSize await
-        let s = magnitude (goertzel (dftSizeF / 24) dftSize c)
-            a = sum (map abs c) / dftSizeF
-            sigLevel = (s * 2) / dftSizeF / a
-        return (c, sigLevel)
-      acquireSignal = do
-        (chunk, sigLevel) <- lockChunk
-        if sigLevel < 0.9
-          then acquireSignal
-          else pure ()
-      maintainLock = do
-        (chunk, sigLevel) <- lockChunk
-        guard (sigLevel > 0.3)
-        return chunk
-      lockedSignal =
-        construct $ do
-          acquireSignal
-          skipStartupNoise
-          forever $ do
-            chunk <- maintainLock
-            mapM_ yield chunk
-      calcSignalNormalizer = do
-        sample <- replicateM (10 * dftSize) await
-        let dco = sum sample / (dftSizeF * 10)
-            maxAmp = maximum (map (\x -> abs (x - dco)) sample)
-            normalize x = (x - dco) / maxAmp
-        mapM_ (yield . normalize) sample
-        return normalize
-      skipStartupNoise = replicateM_ (10 * dftSize) await
-      normalizedSignal = construct $ do
-        skipStartupNoise
-        normalize <- calcSignalNormalizer
-        forever $ do
-          x <- await
-          yield (normalize x)
-  in normalizedSignal <~
-     Filter.Basic.bandPass12db (fromIntegral dataRate) sampleRate <~
-     lockedSignal
-
--- Temporary until lockSignal becomes a Process
-decodeSignal :: Process Float TWord
-decodeSignal = fskDecode <~ lockSignal
-
-tFromAmp :: Float -> TWord
-tFromAmp x
-  | x >= 0.8 = Sync
-  | x >= 0.5 = One
-  | x >= 0.1 = Zero
-  | otherwise = Empty
+decodeSignal :: Process Float Bool
+decodeSignal = codecDec ucode <~ lockSignal dataRate sampleRate
 
-tChunkSize = 256
-
-tToBit :: TWord -> Maybe Bool
-tToBit Sync = Nothing
-tToBit One = Just True
-tToBit Zero = Just False
-tToBit Empty = Nothing
-
-tToBits :: Process TWord Bool
-tToBits =
-  construct . forever $ do
-    word <- await
-    mapM_ yield (tToBit word)
-
-tFromBit :: Bool -> TWord
-tFromBit True = One
-tFromBit False = Zero
-
-
-tFromBits :: Process Bool TWord
-tFromBits =
-  construct $ do
-    replicateM_ 48000 (yield Sync) -- Header
-    forever $ do
-      replicateM_ 4 (yield Sync) -- Chunk header
-      replicateM_ tChunkSize $ do
-        bit <- await
-        yield (tFromBit bit)
-
-
--- # == 3/3 T
--- # == 2/3 F
--- # == 1/3 -
-fskDecode :: Process Float TWord
-fskDecode =
-  let notEmpty x = tFromAmp (abs x) /= Empty
-      polarity x = x < 0
-      eqPolarity x y = polarity x == polarity y
-  in mapping tFromAmp <~ groupingOn eqPolarity (largest <~ mapping abs) <~
-     filtered notEmpty
-
-fskEncode :: Process TWord Float
-fskEncode = construct . forever $ do
-  positive <- await
-  yield (tAmp positive)
-  negative <- await
-  yield (-(tAmp negative))
-
-fskEncodePCM :: Int -> Int -> Process TWord Float
-fskEncodePCM hz sr =
+encodePCM :: Int -> Int -> Process Bool Word8
+encodePCM hz sr =
   let duration = sr `div` hz `div` 2
       extendSamples =
         construct . forever $ do
           x <- await
           replicateM_ duration (yield x)
-  in extendSamples <~ fskEncode
+  in codecEnc pcms16le <~ extendSamples <~ codecEnc ucode
 
-fskEncodeTone :: Int -> Process TWord Builder
-fskEncodeTone hz =
+encodeTone :: Int -> Process Bool Builder
+encodeTone hz =
   let duration = fromIntegral $ 10 ^ (9 :: Int) `div` hz `div` 2
       excursion = 12000
       tones =
@@ -194,81 +44,32 @@ fskEncodeTone hz =
           yield (doubleLE (float2Double (tone * excursion)))
           yield (word32LE duration)
           yield (word32LE 0)
-  in tones <~ fskEncode
+  in tones <~ codecEnc ucode
 
-fskEncodePCM48 = fskEncodePCM dataRate sampleRate
+encodePCM48 :: Process Bool Word8
+encodePCM48 = encodePCM dataRate sampleRate
 
-fskEncodeTone48 = fskEncodeTone dataRate
-
-toPCMS16LE :: Process Float Builder
-toPCMS16LE =
-  let clamp x
-        | x < -1 = -1
-        | x > 1 = 1
-        | otherwise = x
-      toS16LE x = int16LE (floor (32767 * clamp x))
-  in mapping toS16LE
+encodeTone48 :: Process Bool Builder
+encodeTone48 = encodeTone dataRate
 
 sourceByteString :: ByteString -> Source Word8
 sourceByteString = unfold B.uncons
 
-fromPCMS16LE :: Process Word8 Float
-fromPCMS16LE =
-  construct . forever $ do
-    l <- await
-    h <- await
-    let lo = fromIntegral l :: Int16
-        hi = fromIntegral h :: Int16
-    yield (fromIntegral (lo + hi * 256) / 32767)
-
-
-bitsToBytes :: Process Bool Word8
-bitsToBytes = mapping toWord <~ buffered 8
-  where
-    f n True w = setBit w n
-    f _ False w = w
-    toWord = foldl' (flip ($)) 0 . zipWith f [0 ..]
-
-bytesToBits :: Process Word8 Bool
-bytesToBits =
-  construct . forever $ do
-    word <- await
-    forM_ [0 .. 7] (\n -> yield (testBit word n))
-
-readPCM :: IO [Float]
-readPCM = do
-  input <- fmap sourceByteString B.getContents
-  return (run (fromPCMS16LE <~ input))
-
-writePCM :: [Float] -> IO ()
-writePCM xs =
-  B.putStr (toLazyByteString (runIdentity (foldT (toPCMS16LE <~ source xs))))
-
 main :: IO ()
 main = do
   args <- getArgs
   case args of
     ["enc_pcm"] -> do
       input <- fmap sourceByteString B.getContents
-      let output = fold (toPCMS16LE <~ fskEncodePCM48 <~ tFromBits <~ bytesToBits <~ input)
-      B.putStr (toLazyByteString output)
+      let output = B.pack (run (encodePCM48 <~ codecEnc bitsLE <~ input))
+      B.putStr output
     ["enc"] -> do
       input <- fmap sourceByteString B.getContents
-      let output = fold (fskEncodeTone48 <~ tFromBits <~ bytesToBits <~ input)
+      let output = fold (encodeTone48 <~ codecEnc bitsLE <~ input)
       B.putStr (toLazyByteString output)
     ["dec"] -> do
         input <- fmap sourceByteString B.getContents
-        let output = B.pack (run (bitsToBytes <~ tToBits <~ fskDecode <~ fromPCMS16LE <~ input))
+        let output = B.pack (run (codecDec bitsLE <~ decodeSignal <~ codecDec pcms16le <~ input))
         B.putStr output
-    ["lowpass6"] -> (lowPass6db 400 <$> readPCM) >>= writePCM
-    ["lowpass12"] -> (lowPass12db 400 <$> readPCM) >>= writePCM
-    ["lowpass24"] -> (lowPass24db 400 <$> readPCM) >>= writePCM
-    ["highpass6"] -> (highPass6db 400 <$> readPCM) >>= writePCM
-    ["highpass12"] -> (highPass12db 400 <$> readPCM) >>= writePCM
-    ["highpass24"] -> (highPass24db 400 <$> readPCM) >>= writePCM
-    ["bandpass6"] -> (bandPass6db 400 <$> readPCM) >>= writePCM
-    ["bandpass12"] -> (bandPass12db 400 <$> readPCM) >>= writePCM
-    ["bandpass24"] -> (bandPass24db 400 <$> readPCM) >>= writePCM
-    {-["lock"] -> (lockSignal <$> readPCM) >>= writePCM-}
-    _ -> putStrLn "Usage: fsk <enc_pcm|enc|dec|lowpass6|lowpass12|lowpass24>"
+    _ -> putStrLn "Usage: fsk <enc_pcm|enc|dec>"
 

library/VaporTrail/Codec/Bits.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+module VaporTrail.Codec.Bits (Endianness(..), bits, bitsLE, bitsBE) where
+
+import Control.Monad
+import Data.Bits
+import Data.Machine
+import VaporTrail.Codec.Type
+
+data Endianness
+  = LittleEndian
+  | BigEndian
+  deriving (Eq, Read, Show, Enum, Ord)
+
+bitIndex :: Endianness -> Int -> Int -> Int
+bitIndex LittleEndian _ = \(!n) -> n
+bitIndex BigEndian !numBits = \(!n) -> numBits - 1 - n
+
+toBits :: forall b. FiniteBits b => Endianness -> Process b Bool
+toBits !endian =
+  let numBits = finiteBitSize (zeroBits :: b)
+      yieldBit !x !n = yield (testBit x (bitIndex endian numBits n))
+  in construct . forever $ do
+       x <- await
+       forM_ [0 .. numBits - 1] (yieldBit x)
+
+fromBits :: forall b. FiniteBits b => Endianness -> Process Bool b
+fromBits !endian =
+  let numBits = finiteBitSize (zeroBits :: b)
+      putBit !x !n True = setBit x (bitIndex endian numBits n)
+      putBit !x _ False = x
+      awaitBit !x !n = do
+        b <- await
+        return (putBit x n b)
+  in construct . forever $ do
+       x <- foldM awaitBit zeroBits [0 .. numBits - 1]
+       yield x
+
+bits :: FiniteBits b => Endianness -> Codec b Bool
+bits !endian = Codec {codecEnc = toBits endian, codecDec = fromBits endian}
+
+bitsBE :: FiniteBits b => Codec b Bool
+bitsBE = bits BigEndian
+
+bitsLE :: FiniteBits  b => Codec b Bool
+bitsLE = bits LittleEndian

library/VaporTrail/Codec/PCM.hs

@@ -0,0 +1,41 @@
+module VaporTrail.Codec.PCM (pcms16le) where
+
+import Control.Monad
+import Data.Bits
+import Data.Int
+import Data.Machine
+import Data.Word
+import VaporTrail.Codec.Type
+
+clip :: Float -> Float
+clip x = min 1 (max (-1) x)
+
+pcms16le :: Codec Float Word8
+pcms16le =
+  Codec
+  { codecEnc =
+      let toInt16 :: Float -> Int16
+          toInt16 x =
+            if x < 0
+              then floor (32768 * clip x)
+              else floor (32767 * clip x)
+      in construct . forever $ do
+           x <- fmap toInt16 await
+           let lo = fromIntegral (x .&. 0xFF)
+               hi = fromIntegral (shiftR x 8 .&. 0xFF)
+           yield lo
+           yield hi
+  , codecDec =
+      let fromInt16 :: Int16 -> Float
+          fromInt16 x =
+            if x < 0
+              then fromIntegral x / 32768
+              else fromIntegral x / 32767
+      in construct . forever $ do
+           l <- await
+           h <- await
+           let lo = fromIntegral l :: Int16
+               hi = fromIntegral h :: Int16
+               x = lo .|. shiftL hi 8
+           yield (fromInt16 x)
+  }

library/VaporTrail/Codec/Type.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE RankNTypes #-}
+module VaporTrail.Codec.Type
+  ( Codec(..)
+  ) where
+
+import Data.Machine
+
+data Codec a b = Codec
+  { codecEnc :: Process a b
+  , codecDec :: Process b a
+  }
+