hsc3-forth (empty) → 0.15
raw patch · 4 files changed
+318/−0 lines, 4 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, hashable, hosc, hsc3, hsc3-db, hsc3-dot, mtl, unix
Files
- README +78/−0
- Setup.hs +2/−0
- hs/hsc3-forth.hs +202/−0
- hsc3-forth.cabal +36/−0
+ README view
@@ -0,0 +1,78 @@+FORTH SUPERCOLLIDER+-------------------++`HSC3-FORTH` is a simple [FORTH][forth] interpreter.++The only data type is the [SUPERCOLLIDER][sc3] `UNIT GENERATOR`.++A FORTH answer to the eternal question,+[WHY SUPERCOLLIDER?](sw/hsc3-graphs/html/why-supercollider.scd.html)++~~~~+: RVB 5 0 DO 0.05 0 0.05 RAND.IR 2 CLONE 1 ALLPASSN LOOP ; 0.2 DUST.AR+50 * 200 3200 RAND.IR 0.003 RESONZ 10 CLONE MIX DUP 0.046 0.048 DELAYN+0.1 0 0.1 RAND.IR LFNOISE1.KR 0.04 * 0.05 + 15 COMBL 7 CLONE MIX RVB+0.2 * + PLAY+~~~~++[![][img]][img]++[img]: sw/hsc3-graphs/svg/why-supercollider.svg++There is an HSC3-FORTH [EMACS][emacs] mode, a derivative of [FORTH-MODE][gforth].++There is an OSX (10.9.3) binary ([hsc3-forth](sw/hsc3-forth/osx/hsc3-forth.xz).[xz](http://tukaani.org/xz/)),+or to build type:++~~~~+cd hs ; prefix=~/opt make install+~~~~++An environment variable locates the HSC3-FORTH library files:++~~~~+export HSC3_FORTH_DIR=$HOME/sw/hsc3-forth/fs+~~~~++To hear the above type `C-cC-r` in EMACS, or in a shell type:++~~~~+hsc3-forth < ~/sw/hsc3-graphs/gr/why-supercollider.fs+~~~~++To quieten there is the word `STOP`.++There is a [TUTORIAL](?t=hsc3-forth&e=help/tutorial.fs), and+[TRANSLATIONS](?t=hsc3-forth&e=help/jmcc.fs) of graphs by [JAMES+MCCARTNEY](http://audiosynth.com/autobio/emu.jpg) from the `SC2`+manual.++HSC3-FORTH is `CASE-INSENSITIVE`, in EMACS you can type `C-xC-l` to+time travel.++It follows the [HASKELL][hs] SUPERCOLLIDER ([HSC3][hsc3]) rules.++It thinks `scsynth` is listening at the standard port (57110).++<!--+It is very partial, it is known to work as far as the translated+graphs at [HSC3-GRAPHS](?t=hsc3-graphs), search for `FS` in the+[INDEX](?t=hsc3-graphs&e=md/ix.md).+-->++HSC3-FORTH is for [FORTH IMPACT](http://forthimpact.bandcamp.com/).++<!--+([AG](http://www.alexandergarsden.com/) and [SD](http://www.samueldunscombe.com/)+-->++© [RD][rd], 2014, [gpl][gpl].++[rd]: http://rd.slavepianos.org/+[hsc3]: ?t=hsc3+[hs]: http://haskell.org/+[sc3]: http://audiosynth.com/+[forth]: http://www.forth.org/+[gpl]: http://gnu.org/copyleft/+[gforth]: http://www.gnu.org/software/gforth/+[emacs]: http://www.gnu.org/software/emacs/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hs/hsc3-forth.hs view
@@ -0,0 +1,202 @@+import Control.Concurrent {- base -}+import Control.Monad {- base -}+import Control.Monad.Except {- mtl -}+import Control.Monad.State {- mtl -}+import Data.Char {- hash -}+import Data.Hashable {- hash -}+import qualified Data.Map as M {- containers -}+import Data.Maybe {- base -}+import System.IO {- base -}++import Sound.OSC {- hosc -}+import Sound.SC3 {- hsc3 -}+import Sound.SC3.Common {- hsc3 -}+import Sound.SC3.UGen.Plain {- hsc3 -}+import Sound.SC3.UGen.PP {- hsc3 -}++import qualified Sound.SC3.UGen.DB as DB {- hsc3-db -}+import qualified Sound.SC3.UGen.DB.Record as DB {- hsc3-db -}+import qualified Sound.SC3.UGen.DB.PP as DB {- hsc3-db -}++import Sound.SC3.UGen.Dot {- hsc3-dot -}++import Forth++-- * Forth++-- | hsc3-forth word.+type U_Forth r = Forth Int UGen r++-- | 'replicateM' of 'pop'.+pop_n :: Int -> Forth w a [a]+pop_n n = replicateM n pop++-- | 'mapM_' of 'push'.+push_l :: [a] -> Forth w a ()+push_l = mapM_ push++pop_double :: String -> Forth w UGen Double+pop_double msg =+ let f u = case constant_opt u of+ Nothing -> throw_error ("POP_DOUBLE: " ++ msg ++ ": " ++ show u)+ Just n -> return n+ in pop >>= f++-- | Get UId counter.+get_uid :: Forth Int a Int+get_uid = with_vm (\vm -> (vm,world vm))++-- | Store UId counter.+set_uid :: Int -> Forth Int a ()+set_uid k = with_vm (\vm -> (vm {world = k},()))++-- | Get UId counter and store increment.+incr_uid :: Forth Int a Int+incr_uid = with_vm (\vm -> let k = world vm in (vm {world = k + 1},k))++-- | Assert that the stack is empty.+fw_assert_empty :: Forth_Type a => Forth w a ()+fw_assert_empty = do+ vm <- get+ case stack vm of+ [] -> return ()+ l -> throw_error ("STACK NOT EMPTY: " ++ unwords (map show l))++ugen_sep :: String -> Forth w a (String,Maybe Rate)+ugen_sep = maybe (throw_error "UGEN NAME RATE SEPARATOR FAILED") return . sc3_ugen_name_sep++-- * UForth++-- DEMAND makes this two stage, since inputs are known until we know if to pop NC.+get_nc :: DB.U -> Maybe Int -> U_Forth (Maybe Int)+get_nc u nc =+ case nc of+ Just n -> return (Just n)+ Nothing -> case DB.ugen_nc_mce u of+ Just _ -> return Nothing+ Nothing -> fmap Just (pop_int "GET_NC")++-- > fmap ugen_io (DB.uLookup CI "DSEQ")+-- > fmap ugen_io (DB.uLookup CI "DEMAND")+ugen_io :: DB.U -> (Int,Maybe Int)+ugen_io u = (length (DB.ugen_inputs u),DB.u_fixed_outputs u)++gen_plain :: String -> U_Forth ()+gen_plain w = do+ (nm,rt) <- ugen_sep w+ let (nm',sp) = case rt of+ Nothing -> resolve_operator CI nm+ _ -> (nm,Nothing)+ sp' = Special (fromMaybe 0 sp)+ u <- case DB.uLookup CI nm' of+ Nothing -> throw_error ("DYNAMIC FAILED: UNKNOWN UGEN: " ++ tick_quotes nm')+ Just r -> return r+ when (isNothing rt && isNothing (DB.ugen_filter u))+ (throw_error ("OSC: NO RATE?: " ++ tick_quotes nm'))+ let (inp,nc) = ugen_io u+ z <- if DB.ugen_nondet u then fmap UId incr_uid else return NoId+ nc' <- get_nc u nc+ i <- fmap reverse (pop_n inp)+ let nc'' = fromMaybe (length (mceChannels (last i))) nc'+ let rt' = fromMaybe (maximum (map rateOf i)) rt+ i' = (if DB.ugen_std_mce u then halt_mce_transform else id) i+ push (ugen_optimise_const_operator (mk_plain rt' (DB.ugen_name u) i' nc'' sp' z))++gen_nm :: UGen -> String+gen_nm = show . hash . show++sched :: Time -> UGen -> IO ()+sched t u =+ let nm = gen_nm u+ sy = synthdef nm (out 0 u)+ b0 = bundle immediately [d_recv sy]+ b1 = bundle t [s_new nm (-1) AddToHead 1 []]+ in withSC3 (sendBundle b0 >> sendBundle b1)++fw_help :: Forth_Type a => Forth w a ()+fw_help = do+ (nm,_) <- ugen_sep =<< pop_string "HELP: NAME"+ case DB.ugenSummary' CI nm of+ Nothing -> throw_error ("?: NO HELP: " ++ nm)+ Just h -> liftIO (putStrLn h)++fw_manual :: Forth_Type a => Forth w a ()+fw_manual = do+ (nm,_) <- ugen_sep =<< pop_string "MANUAL: NAME"+ case DB.uLookup CI nm of+ Nothing -> throw_error ("MANUAL: NO ENTRY: " ++ nm)+ Just u -> liftIO (viewSC3Help (DB.ugen_name u))++fw_play_at :: U_Forth ()+fw_play_at = do+ grp <- pop_int "PLAY-AT: GRP"+ act <- pop_int "PLAY-AT: ACT"+ nid <- pop_int "PLAY-AT: NID"+ u <- pop+ fw_assert_empty+ liftIO (audition_at (nid,toEnum act,grp) u)++fw_pretty_print :: U_Forth ()+fw_pretty_print = do+ k <- pop_int "PRETTY-PRINT"+ u <- pop+ liftIO (putStrLn (DB.ugen_graph_forth_pp (toEnum k) u))++fw_load_datum :: Char -> U_Forth Datum+fw_load_datum c =+ case c of+ 'i' -> pop_int "LOAD-DATUM: I" >>= return . int32+ 'f' -> pop_double "LOAD-DATUM: F" >>= return . float+ 's' -> pop_string "LOAD-DATUM: S" >>= return . string+ _ -> throw_error ("LOAD-DATUM: UNKNOWN TYPE: " ++ tick_quotes [c])++fw_async :: U_Forth ()+fw_async = do+ nm <- pop_string "ASYNC: MESSAGE-NAME"+ ty <- pop_string "ASYNC: OSC-TYPE-SIG"+ param <- mapM fw_load_datum (reverse (tail ty))+ _ <- liftIO (withSC3 (async (message nm (reverse param))))+ return ()++ugen_dict :: Dict Int UGen+ugen_dict =+ M.fromList $ map (\(nm,en) -> (map toLower nm,en))+ [("clone",pop_int "CLONE" >>= \n -> pop >>= \u -> incr_uid >>= \z -> push (uclone z n u))+ ,("draw",pop >>= \u -> fw_assert_empty >> liftIO (draw (out 0 u)))+ ,("mce",pop_int "MCE" >>= \n -> pop_n n >>= push . mce . reverse)+ ,("mix",pop >>= push . mix) -- here rather hsc3.fs to get sum_opt for graph comparisons...+ ,("mrg",pop_int "MRG" >>= \n -> pop_n n >>= push . mrg . reverse)+ ,("play-at",fw_play_at)+ ,("sched",pop_double "SCHED" >>= \t -> pop >>= \u -> fw_assert_empty >> liftIO (sched t u))+ ,("stop",liftIO (withSC3 reset))+ ,("unmce",pop >>= push_l . mceChannels)+ ,("async",fw_async)+ ,("pause",pop_double "PAUSE" >>= pauseThread)+ ,("time",liftIO time >>= push . constant)+ ,("label",pop_string "LABEL" >>= push . label)+ ,("get-uid",get_uid >>= push . constant)+ ,("set-uid",pop_int "SET-UID" >>= set_uid)+ ,("unrand",pop >>= push . ugen_optimise_ir_rand)+ ,("chan",pop >>= push . constant . length . mceChannels)+ ,("sc3-status",liftIO (withSC3 serverStatus >>= mapM_ putStrLn))+ ,("pretty-print",fw_pretty_print)+ ,("?",fw_help)+ ,("manual",fw_manual)]++instance Forth_Type UGen where+ ty_show = ugen_concise_pp+ ty_to_int = fmap floor . u_constant+ ty_from_int = fromIntegral+ ty_from_bool t = if t then -1 else 0++main :: IO ()+main = do+ sig <- newMVar False+ let d :: Dict Int UGen+ d = M.unions [core_dict,ugen_dict]+ vm = (empty_vm 0 parse_constant sig) {dynamic = Just gen_plain+ ,dict = d+ ,input_port = Just stdin}+ init_f = load_files ["stdlib.fs","hsc3.fs","overlap-texture.fs"]+ putStrLn "HSC3-FORTH"+ repl vm init_f
+ hsc3-forth.cabal view
@@ -0,0 +1,36 @@+Name: hsc3-forth+Version: 0.15+Synopsis: FORTH SUPERCOLLIDER+Description: FORTH SUPERCOLLIDER+License: GPL+Category: Sound+Copyright: (c) Rohan Drape, 2014+Author: Rohan Drape+Maintainer: rd@slavepianos.org+Stability: Experimental+Homepage: http://rd.slavepianos.org/t/hsc3-forth+Tested-With: GHC == 7.8.2+Build-Type: Simple+Cabal-Version: >= 1.8++Data-files: README++executable hsc3-forth+ build-depends: base == 4.*,+ containers,+ directory,+ filepath,+ hashable,+ hosc == 0.15.*,+ hsc3 == 0.15.*,+ hsc3-db == 0.15.*,+ hsc3-dot == 0.15.*,+ mtl,+ unix+ hs-source-dirs: hs+ main-is: hsc3-forth.hs+ ghc-options: -Wall -fno-warn-orphans -fwarn-tabs++Source-Repository head+ Type: darcs+ Location: http://rd.slavepianos.org/sw/hsc3-forth/