From fc4cb83894a81f392a297ab4ea2629ea2ff81a08 Mon Sep 17 00:00:00 2001 From: Julin S Date: Sat, 9 Mar 2024 15:47:14 +0530 Subject: [PATCH] [Haskell] Replicate a youtube video make audio --- haskell/Music.hs | 218 ++++++++++++++++++++++++++++-------- haskell/TypeCheckerAtkey.hs | 43 ++++--- 2 files changed, 194 insertions(+), 67 deletions(-) diff --git a/haskell/Music.hs b/haskell/Music.hs index 89998f5..56187a7 100644 --- a/haskell/Music.hs +++ b/haskell/Music.hs @@ -1,65 +1,185 @@ --- https://hackage.haskell.org/package/bytestring-0.12.1.0/docs/Data-ByteString-Lazy.html#t:LazyByteString -import qualified Data.ByteString.Lazy as BL - --- https://hackage.haskell.org/package/bytestring-0.12.1.0/docs/Data-ByteString-Builder.html -import qualified Data.ByteString.Builder as B - +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Builder as BSB import qualified Data.Foldable import qualified System.Process import qualified Text.Printf - + + +-- Frequency in Hertz type Hz = Float -type Seconds = Float -type Signal = [Float] --- Byte strings with Little Endian 32 bit float +-- Time in seconds +type Sec = Float --- B.floatLE n :: B.Builder +type Wave = [Float] + +type Semitone = Int +type Beat = Float outFile :: FilePath outFile = "out.bin" --- volume :: Float --- volume = 0.2 - --- Number of samples per second --- ie, number of float values per second -sampleRate :: Hz -sampleRate = 48000 - --- step :: Float --- step = 0.01 +save :: Wave -> FilePath -> IO () +save wav outfile + -- Write to outfile + = BSL.writeFile outfile - -duration :: Float -duration = 2.0 + -- Build lazy byte string + $ BSB.toLazyByteString -wave :: Float -> Hz -> Seconds -> Signal -wave volume freq duration - = map (* volume) -- adjust volume - $ map sin -- generate wave - $ map (* step) [0.0 .. sampleRate * duration] - where - step = (freq * 2 * pi) / sampleRate + -- Combine all data points into single bytestring + $ Data.Foldable.fold -sound :: Signal -sound = concat $ map (++) - [wave 0.2 440 duration - wave 0.2 frq secs - -toBS :: [Float] -> B.Builder -toBS wav = Data.Foldable.fold $ map B.floatLE wav - + -- build float little endian byte string for each data point + $ map BSB.floatLE wav --- LazyByteString: Serializable-friendly form of ByteString --- https://hackage.haskell.org/package/bytestring-0.12.1.0/docs/Data-ByteString-Lazy.html#t:LazyByteString -save :: FilePath -> IO () -save outfile = BL.writeFile outfile $ B.toLazyByteString $ toBS sound - -play :: IO () -play = do - save outFile - _ <- System.Process.runCommand - $ Text.Printf.printf "ffplay -showmode 1 -f f32le -ar %f %s" sampleRate outFile +play :: Wave -> IO () +play wav = do + save (map (*volume) wav) outFile + -- save wav outFile + _ <- System.Process.runCommand $ Text.Printf.printf + "ffplay -showmode 1 -f f32le -ar %f %s" + sr outFile return () +----- + +-- Sample rate: Number of data points per second +sr :: Hz +sr = 48000 + +bpm :: Beat +bpm = 120.0 + +volume :: Float +volume = 0.4 +--volume = 10 + + +-- Generate a 'base wave' of given frequency and duration. +-- For use in `wave' function. +genBaseWave :: Hz -> Sec -> Wave +genBaseWave freq duration = map (sin . (*(step freq))) [0.0 .. (sr*duration - 1)] + where + -- Get step size for use in `genBaseWave' + step :: Hz -> Float + step freq = (2 * pi * freq) / sr + +note :: Semitone -> Beat -> Wave +note n beatN = genWave (stFreq n) (beatN * beat1Duration ) + where + beat1Duration = 60/bpm + +-- |Generate a wave of given frequency and duration +genWave :: Hz -> Sec -> Wave +genWave freq duration + = zipWith3 (\a w d -> a * w * d) asc wav dsc + where + wav = genBaseWave freq duration + -- len = fromIntegral $ length wav + asc = map (min 1.0) [0.00, 0.001 .. ] + dsc = reverse $ take (length wav) asc + +-- |Get frequency of a semitone +-- http://web.archive.org/web/20220524232706/https://pages.mtu.edu/~suits/NoteFreqCalcs.html +stFreq :: Semitone -> Hz +stFreq n = f0 + a ** (fromIntegral n) + where + a = 2 ** (1/12) + f0 = 440 -- standard pitch (A440) + +mix :: Wave -> Wave -> Wave +mix = zipWith (\x y -> x + y) + +freqDur :: [(Hz, Sec)] +freqDur = + [(220, 1), + (320, 1), + (440, 1)] +o1 = concat [genWave f d | (f, d) <- freqDur] + + +stBeats2 :: [(Semitone, Beat)] +stBeats2 = + [ (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.5) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.5) + , (5, 0.25) + , (5, 0.25) + , (5, 0.25) + , (5, 0.25) + , (5, 0.25) + , (5, 0.25) + , (5, 0.5) + , (3, 0.25) + , (3, 0.25) + , (3, 0.25) + , (3, 0.25) + , (3, 0.25) + , (3, 0.25) + , (3, 0.5) + , (-2, 0.5) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.25) + , (0, 0.5)] + +o2 = concat [note n bts | (n, bts) <- stBeats2] +o2' = concat [note n bts | (n, bts) <- stB'] + where + stB' = map (\(n,bts) -> (n,bts*2)) stBeats2 + + +stBeats3 :: [(Semitone, Beat)] +stBeats3 = + [ (0, 1) + , (1, 1) + , (2, 1) + , (3, 0.25) + , (4, 0.25) + , (5, 0.25)] +o3 = concat [note n bts | (n, bts) <- stBeats3] + + +stBeats4 :: [(Semitone, Beat)] +stBeats4 = + [ (240, 1.0) + , (270, 1.0) + , (300, 1.0) + , (320, 1.0) + , (360, 1.0) + , (400, 1.0) + , (450, 1.0) + , (480, 1.0)] +o4 = concat [note n bts | (n, bts) <- stBeats4] + + +-- sa re ga ma +freqDur5 :: [(Hz, Sec)] +freqDur5 = + [ (240, 2.0) + , (270, 2.0) + , (300, 2.0) + , (320, 2.0) + , (360, 2.0) + , (400, 2.0) + , (450, 2.0) + , (480, 2.0)] +o5 = concat [genWave f d | (f, d) <- freqDur5] + + + +-- w = wave +-- main :: IO () +-- main = do +-- play a diff --git a/haskell/TypeCheckerAtkey.hs b/haskell/TypeCheckerAtkey.hs index 4aea881..5a4307b 100644 --- a/haskell/TypeCheckerAtkey.hs +++ b/haskell/TypeCheckerAtkey.hs @@ -59,27 +59,28 @@ eg3 = App (Lam Boolean (Var 2)) (Var 0) type TypeChecker = Ctxt -> Maybe Typ -typecheck2 :: Term -> TypeChecker -typecheck2 tm ctxt = case tm of +-- Get typechecker that evaluates to type of given term +tm2Typechecker :: Term -> TypeChecker +tm2Typechecker tm = \ctxt -> case tm of Var i -> var i ctxt - App tm1 tm2 -> app tm1 tm2 ctxt - Lam t tm -> lam t tm ctxt + App tm1 tm2 -> app (tm2Typechecker tm1) (tm2Typechecker tm2) ctxt + Lam ty tm -> lam ty (tm2Typechecker tm) ctxt +-- Inject a variable var :: Int -> TypeChecker var i ctxt = Just $ ctxt !! i -app :: Term -> Term -> TypeChecker -app tm1 tm2 ctxt = case typecheck2 tm1 ctxt of - Just (Arrow ty1 ty2) -> - (case typecheck2 tm2 ctxt of - Just ty' -> if ty2 == ty' then Just ty2 else Nothing - _ -> Nothing) +app :: TypeChecker -> TypeChecker -> TypeChecker +app tc1 tc2 = \ctxt -> case tc1 ctxt of + Just (Arrow ty1 ty2) -> (case tc2 ctxt of + Just ty' -> if ty1 == ty' then Just ty2 else Nothing + _ -> Nothing) Nothing -> Nothing -lam :: Typ -> Term -> TypeChecker -lam t tm ctxt = case typecheck2 tm (t:ctxt) of -- TODO: Attention. Probably wrong - Just ty -> Just $ Arrow t ty - _ -> Nothing +lam :: Typ -> TypeChecker -> TypeChecker +lam ty tc = \ctxt -> case tc (ty:ctxt) of -- TODO: Attention. Probably wrong + Just ty' -> Just $ Arrow ty ty' + _ -> Nothing -- Typechecker whose i-th element in context has type ty have :: Int -> Typ -> TypeChecker -> TypeChecker @@ -99,8 +100,14 @@ hasType ty tc = \ctxt -> case tc ctxt of -- λf:B -> N. λa:B. f a -eg4 :: Term -eg4 = Lam (Arrow Boolean Nat) $ Lam Boolean $ App (Var 1) (Var 0) +tm1 :: Term +tm1 = Lam (Arrow Boolean Nat) $ Lam Boolean $ App (Var 1) (Var 0) -tc1 = lam (Arrow Boolean Nat) --- $ lam Boolean $ app (var 1) (var 0) +tc1 :: TypeChecker +tc1 = lam (Arrow Boolean Nat) (lam Boolean (app (var 1) (var 0))) + +-- Term with a hole: λf:B -> N. λa:B. _ +-- tm2 :: Term +-- tm2 = Lam (Arrow Boolean Nat) (Lam Boolean _) +tc2 :: forall x. TypeChecker +tc2 = \ctxt -> Nothing