[Haskell] Replicate a youtube video make audio

2024-03-09 15:47:14 +05:30 · 2024-03-09 15:47:14 +05:30 · fc4cb83894
parent 5e1e1563e6
commit fc4cb83894
2 changed files with 194 additions and 67 deletions
--- 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
--- 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