mida 0.4.4 → 0.4.5
raw patch · 12 files changed
+580/−133 lines, 12 files
Files
- CHANGELOG.md +7/−1
- README.md +19/−0
- mida.cabal +4/−1
- src/Main.hs +7/−5
- src/Mida/Configuration.hs +9/−9
- src/Mida/Interaction.hs +11/−11
- src/Mida/Interaction/Base.hs +147/−0
- src/Mida/Interaction/Commands.hs +270/−0
- src/Mida/Language.hs +21/−21
- src/Mida/Midi.hs +48/−48
- src/Mida/Representation.hs +6/−6
- src/Mida/Representation/Show.hs +31/−31
CHANGELOG.md view
@@ -1,10 +1,16 @@ # History of changes +## MIDA 0.4.5++* various cosmetic changes;++* make the executable Cabal-installable.+ ## MIDA 0.4.4 * cosmetic corrections in source code; -* switch to better libraries libraries.+* switch to better libraries. ## MIDA 0.4.3
README.md view
@@ -42,7 +42,26 @@ # sh install.sh ``` + or (if you use Stack):++ ```+ $ stack build+ ```+ 5. Done (you can use `uninstall.sh` to uninstall the program).++Alternatively, instead of steps 3–5, you can just:++```+$ cabal install mida+```++In this case you will need to add `~/.cabal/bin` directory to your `PATH`:++```+# in .bashrc or similar+export PATH=$HOME/.cabal/bin:$PATH+``` ## Example
mida.cabal view
@@ -18,7 +18,7 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. name: mida-version: 0.4.4+version: 0.4.5 synopsis: Language for algorithmic generation of MIDI files description: @@ -122,6 +122,9 @@ , StandaloneDeriving , TupleSections , TypeSynonymInstances+ other-modules: Mida.Interaction+ , Mida.Interaction.Base+ , Mida.Interaction.Commands default-language: Haskell2010 test-suite tests
src/Main.hs view
@@ -20,7 +20,9 @@ module Main (main) where import Control.Monad+import Data.Version (showVersion) import Options.Applicative+import Paths_mida (version) import System.Directory (getHomeDirectory, doesFileExist, getCurrentDirectory) import System.FilePath import qualified Data.Map as M@@ -44,17 +46,17 @@ main :: IO () main = execParser opts >>= f where f Opts { opLicense = True } = T.putStr license- f Opts { opVersion = True } = F.print "MIDA {}\n" (F.Only version)- f Opts { opFiles = [] } = g $ interaction version+ f Opts { opVersion = True } = F.print "MIDA {}\n" (F.Only ver)+ f Opts { opFiles = [] } = g $ interaction ver f Opts { opInterac = True- , opFiles = ns } = g $ cmdLoad ns >> interaction version+ , opFiles = ns } = g $ cmdLoad ns >> interaction ver f Opts { opSeed = s , opQuarter = q , opBeats = b , opOutput = out , opFiles = ns } = g $ cmdLoad ns >> cmdMake s q b out- g x = T.putStrLn notice >> runMida x- version = "0.4.4"+ g x = T.putStrLn notice >> runMida x+ ver = showVersion version notice :: T.Text notice =
src/Mida/Configuration.hs view
@@ -18,9 +18,9 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Configuration- ( Params- , parseConfig- , lookupCfg )+ ( Params+ , parseConfig+ , lookupCfg ) where import Control.Applicative@@ -36,18 +36,18 @@ type Params = M.Map String String class Parsable a where- parseValue :: String -> Maybe a+ parseValue :: String -> Maybe a instance Parsable String where- parseValue = Just+ parseValue = Just instance Parsable Int where- parseValue = parseNum+ parseValue = parseNum instance Parsable Bool where- parseValue "true" = Just True- parseValue "false" = Just False- parseValue _ = Nothing+ parseValue "true" = Just True+ parseValue "false" = Just False+ parseValue _ = Nothing lookupCfg :: Parsable a => Params -> String -> a -> a lookupCfg cfg v d = fromMaybe d $ M.lookup v cfg >>= parseValue
src/Mida/Interaction.hs view
@@ -19,17 +19,17 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Interaction- ( MidaIO- , MidaInt- , runMidaInt- , MidaSt (..)- , MidaCfg (..)- , cmdLoad- , cmdMake- , interaction- , dfltSeed- , dfltQuarter- , dfltBeats )+ ( MidaIO+ , MidaInt+ , runMidaInt+ , MidaSt (..)+ , MidaCfg (..)+ , cmdLoad+ , cmdMake+ , interaction+ , dfltSeed+ , dfltQuarter+ , dfltBeats ) where import Control.Monad.Reader
+ src/Mida/Interaction/Base.hs view
@@ -0,0 +1,147 @@+-- -*- Mode: Haskell; -*-+--+-- This module describes monad for interactive REPL and some basic+-- functions.+--+-- Copyright © 2014, 2015 Mark Karpov+--+-- MIDA is free software: you can redistribute it and/or modify it under the+-- terms of the GNU General Public License as published by the Free Software+-- Foundation, either version 3 of the License, or (at your option) any+-- later version.+--+-- MIDA is distributed in the hope that it will be useful, but WITHOUT ANY+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+-- FOR A PARTICULAR PURPOSE. See the GNU General Public License for more+-- details.+--+-- You should have received a copy of the GNU General Public License along+-- with this program. If not, see <http://www.gnu.org/licenses/>.++{-# OPTIONS -fno-warn-orphans #-}++module Mida.Interaction.Base+ ( MidaIO+ , MidaInt+ , runMidaInt+ , MidaSt (..)+ , MidaCfg (..)+ , lift+ , liftEnv+ , getPrevLen+ , setPrevLen+ , getSrcFile+ , setSrcFile+ , getProg+ , setProg+ , getTempo+ , setTempo+ , getPrompt+ , getVerbose+ , getPrvCmd+ , getProgOp+ , getTempoOp+ , dfltSeed+ , dfltQuarter+ , dfltBeats+ , processDef )+where++import Control.Monad.Reader+import Control.Monad.State.Strict++import qualified Data.Text.Format as F+import qualified System.Console.Haskeline as L++import Mida.Language++type MidaIO = MidaInt IO++newtype MidaInt m a = MidaInt+ { unMidaInt :: StateT MidaSt (ReaderT MidaCfg (MidaEnv m)) a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadState MidaSt+ , MonadReader MidaCfg+ , MonadIO )++instance MonadTrans MidaInt where+ lift = MidaInt . lift . lift . lift++liftEnv :: (Monad m) => MidaEnv m a -> MidaInt m a+liftEnv = MidaInt . lift . lift++deriving instance L.MonadException m => L.MonadException (MidaEnv m)+deriving instance L.MonadException m => L.MonadException (MidaInt m)++data MidaSt = MidaSt+ { stPrevLen :: Int+ , stSrcFile :: String+ , stProg :: Int+ , stTempo :: Int }++data MidaCfg = MidaCfg+ { cfgPrompt :: String+ , cfgVerbose :: Bool+ , cfgPrvCmd :: String+ , cfgProgOp :: String+ , cfgTempoOp :: String }++runMidaInt :: Monad m => MidaInt m a -> MidaSt -> MidaCfg -> m a+runMidaInt m st cfg = runMidaEnv (runReaderT (evalStateT (unMidaInt m) st) cfg)++getPrevLen :: MidaIO Int+getPrevLen = gets stPrevLen++setPrevLen :: Int -> MidaIO ()+setPrevLen x = modify $ \e -> e { stPrevLen = x }++getSrcFile :: MidaIO String+getSrcFile = gets stSrcFile++setSrcFile :: String -> MidaIO ()+setSrcFile x = modify $ \e -> e { stSrcFile = x }++getProg :: MidaIO Int+getProg = gets stProg++setProg :: Int -> MidaIO ()+setProg x = modify $ \e -> e { stProg = x }++getTempo :: MidaIO Int+getTempo = gets stTempo++setTempo :: Int -> MidaIO ()+setTempo x = modify $ \e -> e { stTempo = x }++getPrompt :: MidaIO String+getPrompt = asks cfgPrompt++getVerbose :: MidaIO Bool+getVerbose = asks cfgVerbose++getPrvCmd :: MidaIO String+getPrvCmd = asks cfgPrvCmd++getProgOp :: MidaIO String+getProgOp = asks cfgProgOp++getTempoOp :: MidaIO String+getTempoOp = asks cfgTempoOp++dfltSeed :: Int+dfltSeed = 0++dfltQuarter :: Int+dfltQuarter = 24++dfltBeats :: Int+dfltBeats = 16++processDef :: String -> SyntaxTree -> MidaIO ()+processDef n t = do+ recursive <- liftEnv $ checkRecur n t+ if recursive+ then liftIO $ F.print "Rejected recursive definition for «{}».\n" (F.Only n)+ else liftEnv (addDef n t) >> liftIO (F.print "• «{}»\n" (F.Only n))
+ src/Mida/Interaction/Commands.hs view
@@ -0,0 +1,270 @@+-- -*- Mode: Haskell; -*-+--+-- This module describes all supported MIDA commands. It also provides all+-- the functionality to load source files and generate / save MIDI files.+--+-- Copyright © 2014, 2015 Mark Karpov+--+-- MIDA is free software: you can redistribute it and/or modify it under the+-- terms of the GNU General Public License as published by the Free Software+-- Foundation, either version 3 of the License, or (at your option) any+-- later version.+--+-- MIDA is distributed in the hope that it will be useful, but WITHOUT ANY+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+-- FOR A PARTICULAR PURPOSE. See the GNU General Public License for more+-- details.+--+-- You should have received a copy of the GNU General Public License along+-- with this program. If not, see <http://www.gnu.org/licenses/>.++module Mida.Interaction.Commands+ ( processCmd+ , completionFunc+ , cmdLoad+ , cmdMake+ , cmdPrefix )+where++import Control.Exception (SomeException, try)+import Control.Monad (void)+import Control.Monad.IO.Class+import Data.Char (isSpace)+import Data.Foldable (find)+import Data.List (elemIndex, isPrefixOf)+import Data.Maybe (fromMaybe, listToMaybe)+import System.Directory+ ( canonicalizePath+ , doesDirectoryExist+ , doesFileExist+ , getCurrentDirectory+ , getHomeDirectory+ , getTemporaryDirectory+ , setCurrentDirectory )+import System.Exit (exitSuccess)+import System.FilePath+ ( addTrailingPathSeparator+ , joinPath+ , replaceExtension+ , splitDirectories+ , takeFileName+ , (</>) )+import System.Process+ ( shell+ , createProcess+ , waitForProcess+ , delegate_ctlc )+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T++import qualified Codec.Midi as Midi+import qualified Data.Text.Format as F+import qualified System.Console.Haskeline as L++import Mida.Interaction.Base+import Mida.Language+import Mida.Midi+import Mida.Representation++data Cmd = Cmd+ { cmdName :: String+ , cmdFunc :: String -> MidaIO ()+ , cmdDesc :: T.Text+ , cmdComp :: CompletionScheme }++data CompletionScheme = None | Files | Names deriving (Eq, Show)++commands :: [Cmd]+commands =+ [ Cmd "cd" cmdCd "Change working directory" Files+ , Cmd "clear" cmdClear "Restore default state of environment" None+ , Cmd "def" cmdDef "Print definition of given symbol" Names+ , Cmd "help" cmdHelp "Show this help text" None+ , Cmd "load" cmdLoad' "Load definitions from given file" Files+ , Cmd "make" cmdMake' "Generate and save MIDI file" Files+ , Cmd "prog" cmdProg "Set program for preview" None+ , Cmd "prv" cmdPrv "Play the score with external program" None+ , Cmd "prvlen" cmdLength "Set length of displayed results" None+ , Cmd "purge" cmdPurge "Remove redundant definitions" None+ , Cmd "pwd" cmdPwd "Print working directory" None+ , Cmd "quit" cmdQuit "Quit the interactive environment" None+ , Cmd "save" cmdSave "Save current environment in file" Files+ , Cmd "tempo" cmdTempo "Set tempo for preview" None+ , Cmd "udef" cmdUdef "Remove definition of given symbol" Names ]++processCmd :: T.Text -> MidaIO ()+processCmd txt =+ case find g commands of+ Just Cmd { cmdFunc = f } -> f . T.unpack . T.strip $ args+ Nothing -> liftIO $ F.print "Unknown command, try {}help.\n"+ (F.Only cmdPrefix)+ where g Cmd { cmdName = c } = c == dropCmdPrefix (T.unpack cmd)+ (cmd, args) = T.break isSpace (T.strip txt)++completionFunc :: L.CompletionFunc MidaIO+completionFunc = L.completeWordWithPrev Nothing " " getCompletions++getCompletions :: String -> String -> MidaIO [L.Completion]+getCompletions prev word = do+ names <- liftEnv getRefs+ files <- L.listFiles word+ let cmds = (cmdPrefix ++) . cmdName <$> commands+ g None = []+ g Files = files+ g Names = f names+ return $ case words . reverse $ prev of+ [] -> f $ cmds ++ names+ (c:_) -> case c `elemIndex` cmds of+ Just i -> g . cmdComp $ commands !! i+ Nothing -> f names+ where f = fmap L.simpleCompletion . filter (word `isPrefixOf`)++cmdCd :: String -> MidaIO ()+cmdCd path = liftIO $ do+ new <- addTrailingPathSeparator . (</> path) <$> getCurrentDirectory+ present <- doesDirectoryExist new+ if present+ then do corrected <- canonicalizePath new+ setCurrentDirectory corrected+ F.print "Changed to \"{}\".\n" (F.Only corrected)+ else F.print "Cannot cd to \"{}\".\n" (F.Only new)++cmdClear :: String -> MidaIO ()+cmdClear _ = liftEnv clearDefs >> liftIO (T.putStrLn "Environment cleared.")++cmdDef :: String -> MidaIO ()+cmdDef arg = mapM_ f (words arg)+ where f name = liftEnv (getSrc name) >>= liftIO . T.putStr++cmdHelp :: String -> MidaIO ()+cmdHelp _ = liftIO (T.putStrLn "Available commands:") >> mapM_ f commands+ where f Cmd { cmdName = c, cmdDesc = d } =+ liftIO $ F.print " {}{}{}\n" (cmdPrefix, F.right 24 ' ' c, d)++cmdLoad' :: String -> MidaIO ()+cmdLoad' = cmdLoad . words++cmdLoad :: [String] -> MidaIO()+cmdLoad = mapM_ loadOne++loadOne :: String -> MidaIO ()+loadOne given = do+ file <- output given ""+ b <- liftIO $ doesFileExist file+ if b+ then do contents <- liftIO $ T.readFile file+ case parseMida (takeFileName file) contents of+ Right x -> do mapM_ f x+ setFileName file+ liftIO $ F.print "\"{}\" loaded successfully.\n"+ (F.Only file)+ Left x -> liftIO $ F.print "Parse error in {}.\n" (F.Only x)+ else liftIO $ F.print "Could not find \"{}\".\n" (F.Only file)+ where f (Definition n t) = processDef n t+ f (Exposition _) = return ()++cmdMake' :: String -> MidaIO ()+cmdMake' arg =+ let (s:q:b:f:_) = words arg ++ repeat ""+ in cmdMake (parseNum s dfltSeed)+ (parseNum q dfltQuarter)+ (parseNum b dfltBeats)+ f++cmdMake :: Int -> Int -> Int -> String -> MidaIO ()+cmdMake s q b f = do+ file <- output f "mid"+ midi <- liftEnv $ genMidi s q b+ result <- liftIO $ try (Midi.exportFile file midi)+ case result of+ Right _ -> liftIO $ F.print "MIDI file saved as \"{}\".\n" (F.Only file)+ Left e -> spitExc e++cmdProg :: String -> MidaIO ()+cmdProg arg = do+ prog <- getProg+ setProg $ parseNum (trim arg) prog++cmdPrv :: String -> MidaIO ()+cmdPrv arg = do+ prvcmd <- getPrvCmd+ progOp <- getProgOp+ prog <- show <$> getProg+ tempoOp <- getTempoOp+ tempo <- show <$> getTempo+ temp <- liftIO getTemporaryDirectory+ f <- output "" "mid"+ let (s:q:b:_) = words arg ++ repeat ""+ file = temp </> takeFileName f+ cmd = unwords [prvcmd, progOp, prog, tempoOp, tempo, file]+ cmdMake (parseNum s dfltSeed)+ (parseNum q dfltQuarter)+ (parseNum b dfltBeats)+ file+ (_, _, _, ph) <- liftIO $ createProcess (shell cmd) { delegate_ctlc = True }+ liftIO . void $ waitForProcess ph++cmdLength :: String -> MidaIO ()+cmdLength x = getPrevLen >>= setPrevLen . parseNum x++cmdPurge :: String -> MidaIO ()+cmdPurge _ = do+ liftEnv $ purgeEnv topDefs+ liftIO $ T.putStrLn "Environment purged."++cmdPwd :: String -> MidaIO ()+cmdPwd _ = liftIO (getCurrentDirectory >>= putStrLn)++cmdQuit :: String -> MidaIO ()+cmdQuit _ = liftIO exitSuccess++cmdSave :: String -> MidaIO ()+cmdSave given = do+ file <- output given ""+ src <- liftEnv fullSrc+ result <- liftIO (try (T.writeFile file src) :: IO (Either SomeException ()))+ case result of+ Right _ -> setFileName file >>+ liftIO (F.print "Environment saved as \"{}\".\n" (F.Only file))+ Left e -> spitExc e++cmdTempo :: String -> MidaIO ()+cmdTempo arg = do+ tempo <- getTempo+ setTempo $ parseNum (trim arg) tempo++cmdUdef :: String -> MidaIO ()+cmdUdef arg = mapM_ f (words arg)+ where f name = do+ liftEnv (remDef name)+ liftIO (F.print "Definition for '{}' removed.\n" (F.Only name))++parseNum :: (Num a, Read a) => String -> a -> a+parseNum s x = fromMaybe x $ fst <$> listToMaybe (reads s)++output :: String -> String -> MidaIO String+output given ext = do+ actual <- getSrcFile+ home <- liftIO getHomeDirectory+ let a = if null ext then actual else replaceExtension actual ext+ g = joinPath . fmap f . splitDirectories $ given+ f x = if x == "~" then home else x+ return $ if null given then a else g++setFileName :: FilePath -> MidaIO ()+setFileName path = (</> path) <$> liftIO getCurrentDirectory >>= setSrcFile++dropCmdPrefix :: String -> String+dropCmdPrefix arg+ | cmdPrefix `isPrefixOf` arg = drop (length cmdPrefix) arg+ | otherwise = arg++cmdPrefix :: String+cmdPrefix = ":"++spitExc :: SomeException -> MidaIO ()+spitExc = liftIO . F.print "× {}.\n" . F.Only . show++trim :: String -> String+trim = f . f+ where f = reverse . dropWhile isSpace
src/Mida/Language.hs view
@@ -18,27 +18,27 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Language- ( SyntaxTree- , Sel (..)- , Principle- , Elt- , Element (..)- , MidaEnv (..)- , runMidaEnv- , addDef- , remDef- , clearDefs- , getPrin- , getSrc- , fullSrc- , getRefs- , purgeEnv- , checkRecur- , setRandGen- , newRandGen- , evalDef- , eval- , toPrin )+ ( SyntaxTree+ , Sel (..)+ , Principle+ , Elt+ , Element (..)+ , MidaEnv (..)+ , runMidaEnv+ , addDef+ , remDef+ , clearDefs+ , getPrin+ , getSrc+ , fullSrc+ , getRefs+ , purgeEnv+ , checkRecur+ , setRandGen+ , newRandGen+ , evalDef+ , eval+ , toPrin ) where import Mida.Language.SyntaxTree (SyntaxTree, Sel (..))
src/Mida/Midi.hs view
@@ -18,8 +18,8 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Midi- ( genMidi- , topDefs )+ ( genMidi+ , topDefs ) where import Control.Monad.State.Strict@@ -33,28 +33,28 @@ import Mida.Language (MidaEnv, setRandGen, evalDef) data Batch = Batch- { btDur :: [Int]- , btVel :: [Int]- , btPch :: [Int]- , _btMod :: Maybe [Int]- , _btBth :: Maybe [Int]- , _btAft :: Maybe [Int]- , _btBnd :: Maybe [Int] }+ { btDur :: [Int]+ , btVel :: [Int]+ , btPch :: [Int]+ , _btMod :: Maybe [Int]+ , _btBth :: Maybe [Int]+ , _btAft :: Maybe [Int]+ , _btBnd :: Maybe [Int] } infixl 4 <!> (<!>) :: ([Int] -> [Int]) -> Batch -> Batch f <!> (Batch d v p m t a b) =- Batch (f d) (f v) (f p) (f <$> m) (f <$> t) (f <$> a) (f <$> b)+ Batch (f d) (f v) (f p) (f <$> m) (f <$> t) (f <$> a) (f <$> b) data ModParams = ModParams- { mpValue :: Int- , mpFigure :: Int- , mpDuration :: Int- , mpChannel :: Int- , mpProducer :: Int -> Int -> M.Message- , mpUpBounds :: (Int, Int)- , mpDnBounds :: (Int, Int) }+ { mpValue :: Int+ , mpFigure :: Int+ , mpDuration :: Int+ , mpChannel :: Int+ , mpProducer :: Int -> Int -> M.Message+ , mpUpBounds :: (Int, Int)+ , mpDnBounds :: (Int, Int) } modP :: ModParams modP = ModParams@@ -106,20 +106,20 @@ slice :: Int -> Batch -> Batch slice t batch@Batch { btDur = dur } = take (f 0 0 dur) <!> batch- where f !i _ [] = i- f !i !a (x:xs) = if x + a >= t then succ i else f (succ i) (x + a) xs+ where f !i _ [] = i+ f !i !a (x:xs) = if x + a >= t then succ i else f (succ i) (x + a) xs toTrack :: Batch -> Int -> Track toTrack (Batch d v p m t a b) i =- concat (zipWith7 f d v p (r m) (r t) (r a) (r b)) ++ [(0, M.TrackEnd)]- where r = maybe (repeat Nothing) (Just <$>)- f d' v' p' m' t' a' b' =- mixEvents- [ figure m' d' i modP- , figure t' d' i bthP- , figure a' d' i aftP- , figure b' d' i bndP- , [(0, M.NoteOn i p' v'), (d', M.NoteOn i p' 0)] ]+ concat (zipWith7 f d v p (r m) (r t) (r a) (r b)) ++ [(0, M.TrackEnd)]+ where r = maybe (repeat Nothing) (Just <$>)+ f d' v' p' m' t' a' b' =+ mixEvents+ [ figure m' d' i modP+ , figure t' d' i bthP+ , figure a' d' i aftP+ , figure b' d' i bndP+ , [(0, M.NoteOn i p' v'), (d', M.NoteOn i p' 0)] ] mixEvents :: [Track] -> Track mixEvents = foldl' mixPair mempty@@ -128,46 +128,46 @@ mixPair [] xs = xs mixPair xs [] = xs mixPair (x:xs) (y:ys) = r : mixPair xs' ys'- where (r, xs', ys')- | fst x <= fst y = (x, xs, f y (fst x) : ys)- | otherwise = (y, f x (fst y) : xs, ys)- f (i, msg) c = (i - c, msg)+ where (r, xs', ys')+ | fst x <= fst y = (x, xs, f y (fst x) : ys)+ | otherwise = (y, f x (fst y) : xs, ys)+ f (i, msg) c = (i - c, msg) figure :: Maybe Int -> Int -> Int -> ModParams -> Track figure Nothing _ _ _ = [] figure (Just raw) d ch p =- fig p { mpValue = v- , mpFigure = f- , mpDuration = d- , mpChannel = ch }- where (f, v) = quotRem raw 128+ fig p { mpValue = v+ , mpFigure = f+ , mpDuration = d+ , mpChannel = ch }+ where (f, v) = quotRem raw 128 fig :: ModParams -> Track fig ModParams { mpDuration = 0 } = [] fig (ModParams v f d ch p ub db) =- maybe [] (zip (0 : repeat 1) . fmap (p ch)) (gen <*> return v)- where gen = listToMaybe $ drop f -- generators:- [ figStc ub -- static- , figRtn ub d -- up & down- , figRtn db d -- down & up- , figLin ub d -- up- , figLin db d ] -- down+ maybe [] (zip (0 : repeat 1) . fmap (p ch)) (gen <*> return v)+ where gen = listToMaybe $ drop f -- generators:+ [ figStc ub -- static+ , figRtn ub d -- up & down+ , figRtn db d -- down & up+ , figLin ub d -- up+ , figLin db d ] -- down figStc :: (Int, Int) -> Int -> [Int] figStc be x = [draw be x 1] figRtn :: (Int, Int) -> Int -> Int -> [Int] figRtn be q x = f <$> [0..l] ++ reverse [0..(q - l - 1)]- where f c = draw be (x * c) l- l = q `div` 2+ where f c = draw be (x * c) l+ l = q `div` 2 figLin :: (Int, Int) -> Int -> Int -> [Int] figLin be q x = f <$> [0..q]- where f c = draw be (x * c) q+ where f c = draw be (x * c) q draw :: (Int, Int) -> Int -> Int -> Int draw (b, e) n d = b + (n * (e - b)) `gdiv` (127 * d)- where x `gdiv` y = round (fromIntegral x / fromIntegral y :: Double)+ where x `gdiv` y = round (fromIntegral x / fromIntegral y :: Double) topDefs :: [String] topDefs = [x ++ show n |
src/Mida/Representation.hs view
@@ -19,12 +19,12 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Representation- ( Statement (..)- , probeMida- , parseMida- , showStatement- , showSyntaxTree- , showPrinciple )+ ( Statement (..)+ , probeMida+ , parseMida+ , showStatement+ , showSyntaxTree+ , showPrinciple ) where import Mida.Representation.Parser
src/Mida/Representation/Show.hs view
@@ -19,10 +19,10 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Representation.Show- ( showStatement- , showDefinition- , showSyntaxTree- , showPrinciple )+ ( showStatement+ , showDefinition+ , showSyntaxTree+ , showPrinciple ) where import Control.Arrow ((***), (>>>))@@ -55,36 +55,36 @@ showSyntaxTree' :: SyntaxTree -> T.Builder showSyntaxTree' t = cm f t <> "\n"- where- cm g xs = mconcat . intersperse " " $ g <$> xs- p x@(Value _) = f x- p x@(Section _) = f x- p x@(Multi _) = f x- p x@(CMulti _) = f x- p x@(Reference _) = f x- p x@(Range _ _) = f x- p x = "(" <> f x <> ")"- f (Value x) = T.decimal x- f (Section x) = "[" <> cm f x <> "]"- f (Multi x) = "{" <> cm f x <> "}"- f (CMulti x) = "{" <> cm (c *** cm f >>> uncurry (<>)) x <> "}"- f (Reference x) = T.fromString x- f (Range x y) = T.decimal x <> T.fromString B.rangeOp <> T.decimal y- f (Product x y) = f x <> pad B.productOp <> p y- f (Division x y) = f x <> pad B.divisionOp <> p y- f (Sum x y) = f x <> pad B.sumOp <> p y- f (Diff x y) = f x <> pad B.diffOp <> p y- f (Loop x y) = f x <> pad B.loopOp <> p y- f (Rotation x y) = f x <> pad B.rotationOp <> p y- f (Reverse x) = T.fromString B.reverseOp <> p x- c xs = "<" <> cm f xs <> "> "+ where+ cm g xs = mconcat . intersperse " " $ g <$> xs+ p x@(Value _) = f x+ p x@(Section _) = f x+ p x@(Multi _) = f x+ p x@(CMulti _) = f x+ p x@(Reference _) = f x+ p x@(Range _ _) = f x+ p x = "(" <> f x <> ")"+ f (Value x) = T.decimal x+ f (Section x) = "[" <> cm f x <> "]"+ f (Multi x) = "{" <> cm f x <> "}"+ f (CMulti x) = "{" <> cm (c *** cm f >>> uncurry (<>)) x <> "}"+ f (Reference x) = T.fromString x+ f (Range x y) = T.decimal x <> T.fromString B.rangeOp <> T.decimal y+ f (Product x y) = f x <> pad B.productOp <> p y+ f (Division x y) = f x <> pad B.divisionOp <> p y+ f (Sum x y) = f x <> pad B.sumOp <> p y+ f (Diff x y) = f x <> pad B.diffOp <> p y+ f (Loop x y) = f x <> pad B.loopOp <> p y+ f (Rotation x y) = f x <> pad B.rotationOp <> p y+ f (Reverse x) = T.fromString B.reverseOp <> p x+ c xs = "<" <> cm f xs <> "> " toSyntaxTree :: Principle -> SyntaxTree toSyntaxTree = (f <$>)- where f (Val x) = Value x- f (Sec x) = Section $ f <$> x- f (Mul x) = Multi $ f <$> x- f (CMul x) = CMulti $ (toSyntaxTree *** toSyntaxTree) <$> x+ where f (Val x) = Value x+ f (Sec x) = Section $ f <$> x+ f (Mul x) = Multi $ f <$> x+ f (CMul x) = CMulti $ (toSyntaxTree *** toSyntaxTree) <$> x pad :: String -> T.Builder pad op = " " <> T.fromString op <> " "