midisurface (empty) → 0.1.0.0
raw patch · 4 files changed
+309/−0 lines, 4 filesdep +alsa-coredep +alsa-seqdep +basesetup-changed
Dependencies added: alsa-core, alsa-seq, base, containers, gtk, mtl, stm
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- midisurface.cabal +67/−0
- surface.hs +210/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ midisurface.cabal view
@@ -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+
+ surface.hs view
@@ -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