diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, paolo.veronelli + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of paolo.veronelli nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/midisurface.cabal b/midisurface.cabal new file mode 100644 --- /dev/null +++ b/midisurface.cabal @@ -0,0 +1,67 @@ +-- Initial midisurface.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: midisurface + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: A control midi surface + +-- A longer description of the package. +description: A simple GTK2 UI to send midi control values. + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: paolo.veronelli + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: paolo.veronelli@gmail.com + +-- A copyright notice. +-- copyright: + +category: Sound + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +executable midisurface + -- .hs or .lhs file containing the Main module. + main-is:surface.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + other-extensions: ViewPatterns + + -- Other library packages from which modules are imported. + build-depends: base >=4.6 && <4.7, alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, stm >=2.4 && <2.5, containers ,gtk,mtl + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + diff --git a/surface.hs b/surface.hs new file mode 100644 --- /dev/null +++ b/surface.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- module GUI where + +import Graphics.UI.Gtk +import Control.Monad +import Control.Monad.Trans + +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +import Data.IORef + + +import MidiComm + + +midichannel = 0 +k = 1/127 + +main :: IO () +main = do + (midiinchan, midioutchan, _) <- midiInOut "midi control GUI" midichannel + thandle <- newTVarIO Nothing + + + initGUI + window <- windowNew + + -- main box + mainbox <- vBoxNew False 1 + set window [windowDefaultWidth := 200, windowDefaultHeight := 200, + containerBorderWidth := 10, containerChild := mainbox] + -- main buttons + coms <- hBoxNew False 1 + boxPackStart mainbox coms PackNatural 0 + res <- buttonNewWithLabel "Sync" + boxPackStart coms res PackNatural 0 + load <- buttonNewFromStock "Load" + boxPackStart coms load PackNatural 0 + fc <- fileChooserButtonNew "Select a file" FileChooserActionOpen + boxPackStart coms fc PackGrow 0 + save <- buttonNewFromStock "Save" + boxPackStart coms save PackNatural 0 + quit <- buttonNewFromStock "Quit" + boxPackStart coms quit PackNatural 0 + + -- main buttons actions + quit `on` buttonActivated $ mainQuit + save `on` buttonActivated $ do + mname <- fileChooserGetFilename fc + case mname of + Nothing -> return () + Just name -> do + h <- openFile name WriteMode + atomically $ writeTVar thandle (Just h) + load `on` buttonActivated $ do + mname <- fileChooserGetFilename fc + case mname of + Nothing -> return () + Just name -> do + h <- openFile name ReadMode + atomically $ writeTVar thandle (Just h) + + -- knobs + -- ad <- adjustmentNew 0 0 400 1 10 400 + -- sw <- scrolledWindowNew Nothing (Just ad) + fillnobbox <- hBoxNew False 1 + boxPackStart mainbox fillnobbox PackNatural 0 + knoblines <- vBoxNew False 1 + boxPackStart fillnobbox knoblines PackNatural 0 + + forM_ [0..3] $ \paramv' -> do + knobboxspace <- hBoxNew True 1 + widgetSetSizeRequest knobboxspace (-1) 10 + boxPackStart knoblines knobboxspace PackNatural 0 + knobbox <- hBoxNew True 1 + boxPackStart knoblines knobbox PackNatural 0 + forM_ [0..31] $ \paramv'' -> do + let paramv= paramv' *32 + paramv'' + when (paramv `mod` 8 == 0) $ do + hbox <- vBoxNew False 1 + boxPackStart knobbox hbox PackNatural 0 + + hbox <- vBoxNew False 1 + widgetSetSizeRequest hbox (-1) 165 + boxPackStart knobbox hbox PackNatural 0 + + param <- labelNew (Just $ show paramv) + widgetSetSizeRequest param 30 15 + frame <- frameNew + set frame [containerChild:= param] + boxPackStart hbox frame PackNatural 0 + + label <- labelNew (Just "0") + widgetSetSizeRequest label 30 15 + frame <- frameNew + set frame [containerChild:= label] + boxPackStart hbox frame PackNatural 0 + + eb <- eventBoxNew + memory <- labelNew (Just $ show (0,0)) + level <- progressBarNew + progressBarSetOrientation level ProgressBottomToTop + set eb [containerChild:= level] + widgetAddEvents eb [Button1MotionMask] + boxPackStart hbox eb PackGrow 0 + progressBarSetFraction level 0 + + exvalue <- newIORef 0 + mute <- toggleButtonNewWithLabel "m" + widgetSetSizeRequest mute 30 16 + frame <- frameNew + set frame [containerChild:= mute] + boxPackStart hbox frame PackNatural 0 + mute `on` toggled $ do + a <- toggleButtonGetActive mute + if a then do + x <- progressBarGetFraction level + writeIORef exvalue x + progressBarSetFraction level 0 + atomically $ writeTChan midioutchan (paramv,0) + else do + x <- readIORef exvalue + progressBarSetFraction level x + atomically $ writeTChan midioutchan (paramv,floor $ x/k) + + + + save `on` buttonActivated $ do + x <- progressBarGetFraction level + mh <- atomically $ readTVar thandle + case mh of + Nothing -> return () + Just h -> hPutStrLn h $ show (floor $ x/k :: Int) + load `on` buttonActivated $ do + mh <- atomically $ readTVar thandle + case mh of + Nothing -> return () + Just h -> do + l <- hGetLine h + let (wx :: Int) = read l + progressBarSetFraction level (fromIntegral wx * k) + labelSetText label $ show wx + labelSetText param $ show paramv + dupchan <- atomically $ dupTChan midiinchan + forkIO . forever $ do + + (tp,wx) <- atomically $ readTChan dupchan + case tp == paramv of + False -> return () + True -> postGUISync $ do + wx' <- read `fmap` (labelGetText label) + case wx' /= wx of + False -> return () + True -> do + progressBarSetFraction level (fromIntegral wx * k) + labelSetText label $ show wx + + + res `on` buttonActivated $ do + x <- progressBarGetFraction level + atomically $ writeTChan midioutchan (paramv,floor $ x/k) + on eb motionNotifyEvent $ do + (_,r) <- eventCoordinates + (0,r') <- liftIO $ fmap read $ labelGetText memory + liftIO $ do + x <- progressBarGetFraction level + let y = (if r < r' then limitedAdd 1 else limitedSubtract 0) k x + progressBarSetFraction level y + atomically $ writeTChan midioutchan (paramv,floor $ y/k) + labelSetText label $ show (floor $ y/k) + labelSetText memory $ show (0,r) + return True + on level scrollEvent $ tryEvent $ do + ScrollUp <- eventScrollDirection + liftIO $ do + x <- progressBarGetFraction level + let y = limitedAdd 1 k x + atomically $ writeTChan midioutchan (paramv,floor $ y/k) + progressBarSetFraction level y + labelSetText label $ show (floor $ y/k) + on level scrollEvent $ tryEvent $ do + ScrollDown <- eventScrollDirection + liftIO $ do + x <- progressBarGetFraction level + let y = limitedSubtract 0 k x + atomically $ writeTChan midioutchan (paramv,floor $ y/k) + progressBarSetFraction level y + labelSetText label $ show (floor $ y/k) + save `on` buttonActivated $ do + mh <- atomically $ readTVar thandle + case mh of + Nothing -> return () + Just h -> hClose h + load `on` buttonActivated $ do + mh <- atomically $ readTVar thandle + case mh of + Nothing -> return () + Just h -> hClose h + + onDestroy window mainQuit + widgetShowAll window + mainGUI + +limitedAdd xm d x + | x + d > xm = xm + | otherwise = x + d +limitedSubtract xm d x + | x - d < xm = xm + | otherwise = x - d