Skip to content

Commit

Permalink
tap tempo view added
Browse files Browse the repository at this point in the history
  • Loading branch information
dktr0 committed Aug 16, 2023
1 parent fb1213d commit 5edf794
Show file tree
Hide file tree
Showing 7 changed files with 93 additions and 2 deletions.
12 changes: 12 additions & 0 deletions client/estuary.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -106,6 +106,18 @@ library
Estuary.Widgets.WebSocket
Estuary.Widgets.ExoWidget
Estuary.Types.AsyncValue
Estuary.Widgets.TapTempo
Estuary.Languages.CineCer0
Estuary.Languages.MiniTidal
Estuary.Languages.Punctual
Estuary.Languages.TimeNot
Estuary.Render.ForeignTempo
Estuary.Render.RenderOp
Estuary.Render.TextNotationRenderer
Estuary.Types.ServerInfo
Estuary.Widgets.Chat
Estuary.Widgets.DataVisualisers

other-modules:
Paths_estuary
hs-source-dirs:
Expand Down
5 changes: 4 additions & 1 deletion client/src/Estuary/Types/Term.hs
Original file line number Diff line number Diff line change
Expand Up @@ -53,7 +53,8 @@ data Term =
IPaddressDescription |
TerminalViewCommands |
Voices |
AddATitle
AddATitle |
Tap
deriving (Show,Eq)

translate :: Term -> Language -> Text
Expand Down Expand Up @@ -223,4 +224,6 @@ translate IPaddressDescription Español = "Las direcciones IP de l@s participant

translate Voices English = "voices"

translate Tap English = "Tap"

translate x _ = translate x English
6 changes: 6 additions & 0 deletions client/src/Estuary/Types/View/Parser.hs
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,7 @@ dumpView (IFrame url) = "iFrame \"" <> url <> "\""
dumpView (CalendarEventView x) = "calendarEvent " <> showInt x
dumpView (LoadView x) = "load " <> showInt x
dumpView (ChatView x) = "chat " <> showInt x
dumpView TapTempoView = "tapTempo"

dumpView _ = " "

Expand Down Expand Up @@ -91,6 +92,7 @@ viewParser = EmptyView <$ reserved "empty" -- localview empty
<|> genGridParser
<|> loadVisionParser
<|> specChatParser
<|> tapTempoParser

genGridParser :: H View
genGridParser = (genGrid <$ reserved "genGrid") <*> rowsOrColumns <*> rowsOrColumns <*> trueOrFalse
Expand Down Expand Up @@ -414,6 +416,10 @@ specChatParser' = specChatFunc <$ reserved "chat"
specChatFunc :: Int -> View
specChatFunc x = ChatView x


tapTempoParser :: H View
tapTempoParser = TapTempoView <$ reserved "tapTempo"

-- helper funcs
int :: H Int
int = fromIntegral <$> integer
Expand Down
63 changes: 63 additions & 0 deletions client/src/Estuary/Widgets/TapTempo.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,63 @@
{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}

module Estuary.Widgets.TapTempo (tapTempoWidget) where

import Reflex
import Reflex.Dom
import Data.Time
import Control.Monad.IO.Class (liftIO,MonadIO)
import TextShow
import Data.Text (Text)
import Data.Tempo
import Control.Monad.Fix

import qualified Estuary.Types.Term as Term
import Estuary.Widgets.W
import Estuary.Widgets.Reflex


slowestBPM :: NominalDiffTime
slowestBPM = 30

fastestBPM :: NominalDiffTime
fastestBPM = 190

tooSlowThreshold :: NominalDiffTime
tooSlowThreshold = 60 / slowestBPM

tooFastThreshold :: NominalDiffTime
tooFastThreshold = 60 / fastestBPM


type TapState = [UTCTime]

averageTimeDiff :: TapState -> NominalDiffTime
averageTimeDiff [] = tooSlowThreshold
averageTimeDiff (_:[]) = tooSlowThreshold
averageTimeDiff ts = (foldl (+) 0 $ zipWith diffUTCTime (init ts) (tail ts)) / realToFrac (length ts - 1)

updateTapState :: TapState -> UTCTime -> (Maybe TapState, Maybe (NominalDiffTime, UTCTime))
updateTapState [] t = (Just [t], Nothing)
updateTapState ts t
| diffUTCTime t (head ts) > tooSlowThreshold = (Just [t], Nothing)
| diffUTCTime t (head ts) < tooFastThreshold = (Just [t], Nothing)
| length ts < 8 = (Just (t:ts), Nothing)
| otherwise = (Just [], Just (averageTimeDiff ts, t))


tapTempoWidget :: (Reflex t, DomBuilder t m, PerformEvent t m, MonadHold t m, MonadFix m, MonadIO (Performable m), PostBuild t m) => W t m ()
tapTempoWidget = do
b <- dynButton =<< term Term.Tap
tapEvTime <- performEvent $ fmap (const $ liftIO getCurrentTime) b
tapsCompleteEv <- mapAccumMaybe_ updateTapState [] tapEvTime
t <- tempo
setTempo $ attachWith calculateNewTempo (current t) tapsCompleteEv


calculateNewTempo :: Tempo -> (NominalDiffTime, UTCTime) -> Tempo
calculateNewTempo oldTempo (ndt, t) = Tempo { freq = f, time = t, Data.Tempo.count = c }
where
f = realToFrac $ 1 / (ndt * 4)
c = realToFrac $ ceiling $ timeToCount oldTempo t


3 changes: 3 additions & 0 deletions client/src/Estuary/Widgets/View.hs
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,7 @@ import Estuary.Widgets.CalendarEvent
import Estuary.Widgets.DataVisualisers
import Estuary.Widgets.Chat
import Estuary.Types.Request
import Estuary.Widgets.TapTempo



Expand Down Expand Up @@ -142,6 +143,8 @@ viewWidget TempoView = return () {- do -- disactivating TempoView - noone uses i
tempoDelta <- holdDyn initialTempo $ fmapMaybe lastTempoChange er
tempoE <- tempoWidget tempoDelta
return $ fmap WriteTempo tempoE -}

viewWidget TapTempoView = tapTempoWidget

viewWidget (Snippet z b n t) = do
let c = if b then "example code-font" else "snippet code-font"
Expand Down
3 changes: 3 additions & 0 deletions client/src/Estuary/Widgets/W.hs
Original file line number Diff line number Diff line change
Expand Up @@ -341,6 +341,9 @@ ensembleName = askEnsemble (Ensemble.ensembleName . ensemble)
tempo :: (Reflex t, MonadFix m, MonadHold t m) => W t m (Dynamic t Tempo)
tempo = askEnsemble (Ensemble.tempo . ensemble)

setTempo :: (Monad m, Reflex t) => Event t Tempo -> W t m ()
setTempo = request . fmap WriteTempo

zones :: (Reflex t, MonadFix m, MonadHold t m) => W t m (Dynamic t (IntMap Definition))
zones = askEnsemble (Ensemble.zones . ensemble)

Expand Down
3 changes: 2 additions & 1 deletion common/src/Estuary/Types/View.hs
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,8 @@ data View =
IFrame Text | -- embedded web page
CalendarEventView Int |
LoadView Int |
ChatView Int
ChatView Int |
TapTempoView
deriving (Show,Eq,Generic)

instance ToJSON View where
Expand Down

0 comments on commit 5edf794

Please sign in to comment.