Lisp.hs

-- * LISP UGEN BINDINGS
module Sound.SC3.UGen.DB.Bindings.Lisp where

import Data.Char {- base -}
import Data.Maybe {- base -}
import Text.Printf {- base -}

import Sound.SC3.Common {- hsc3 -}
import Sound.SC3.UGen.Name {- hsc3 -}
import Sound.SC3.UGen.Operator {- hsc3 -}
import Sound.SC3.UGen.Rate {- hsc3 -}

import qualified Sound.SC3.UGen.DB as DB {- hsc3-db -}
import qualified Sound.SC3.UGen.DB.Bindings as DB {- hsc3-db -}
import qualified Sound.SC3.UGen.DB.Record as DB {- hsc3-db -}
import qualified Sound.SC3.UGen.DB.Rename as DB {- hsc3-db -}

lisp_rate_id :: Rate -> String
lisp_rate_id = map toLower . show

lisp_list_pp :: [String] -> String
lisp_list_pp x = "(list " ++ unwords x ++ ")"

lisp_rate :: DB.U -> (Maybe String,String)
lisp_rate u =
    case DB.ugen_filter u of
      Just ix -> (Nothing,lisp_list_pp (map show ix))
      Nothing -> case DB.ugen_fixed_rate u of
                   Just fx -> (Nothing,lisp_rate_id fx)
                   Nothing -> (Just "rt","rt")

lisp_nc :: DB.U -> String -> (Maybe String,String)
lisp_nc u mc =
    case DB.u_fixed_outputs u of
      Just d -> (Nothing,show d)
      Nothing ->
          if DB.ugen_nc_input u
          then (Just "nc","nc")
          else if DB.ugen_std_mce u
               then (Nothing,printf "(length (mce-channels %s))" mc)
               else error "NC?"

-- | mk-ugen name rate|[ix] inputs mce-input|nil nc special|nil uid|nil
--
-- > let u = "SinOsc Resonz Demand Drand Dwhite BinaryOpUGen SampleRate Abs"
-- > mapM_ (putStrLn . lisp_mk_ugen) (words u)
lisp_mk_ugen :: String -> String
lisp_mk_ugen nm =
  let (nm',sp) = resolve_operator CS nm
      u = case DB.uLookup CI nm' of
         Nothing -> error ("lisp_mk_ugen: unknown ugen: " ++ nm')
         Just r -> r
      z = if DB.ugen_nondet u then "(incr-uid 1)" else "nil"
      i = DB.u_renamed_inputs u
      (i',mc) = DB.bindings_mce u i
      mc' = fromMaybe "nil" mc
      i_k = if null i' then "nil" else "(list " ++ unwords i' ++ ")"
      (rt_var,rt_k) = lisp_rate u
      (nc_var,nc_k) = lisp_nc u mc'
      sp' = case sp of
              Nothing -> "nil"
              Just k -> show k
      param = mcons nc_var (mcons rt_var i)
      lisp_nm = DB.scheme_rename (sc3_name_to_lisp_name nm)
      template_f = concat ["(define %s\n"
                          ,"  (lambda (%s)\n"
                          ,"    (mk-ugen (list \"%s\" %s %s %s %s %s %s))))\n"]
      template_v = "(define %s (mk-ugen (list \"%s\" %s %s %s %s %s %s)))\n"
  in if null param
     then printf template_v lisp_nm nm rt_k i_k mc' nc_k sp' z
     else printf template_f lisp_nm (unwords param) nm rt_k i_k mc' nc_k sp' z

-- | The generated bindings are for @sin-osc@ etc, alias these to @SinOsc@ etc.
--
-- > writeFile "/tmp/alias.lisp" (unlines (map lisp_mk_alias DB.complete_names))
lisp_mk_alias :: String -> String
lisp_mk_alias nm =
  let lisp_nm = DB.scheme_rename (sc3_name_to_lisp_name nm)
  in printf "(define %s %s)" nm lisp_nm

mcons :: Maybe a -> [a] -> [a]
mcons e = case e of {Nothing -> id; Just e' -> (e' :)}

-- > mapM_ putStrLn operator_sym_def
operator_sym_def :: [String]
operator_sym_def =
    let f (bin,sym_nm) =
            let sc3_nm = show bin
            in printf "(define %s %s)" sym_nm (sc3_name_to_lisp_name sc3_nm)
    in map f binaryTable

-- > mapM_ putStrLn scheme_rename_def
scheme_rename_def :: [String]
scheme_rename_def =
    let f nm = printf "(define %s %s)" nm (DB.scheme_rename nm)
    in map f DB.scheme_names