packages feed

padKONTROL (empty) → 0.1

raw patch · 5 files changed

+227/−0 lines, 5 filesdep +basedep +containersdep +hmidisetup-changed

Dependencies added: base, containers, hmidi, minioperational, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Fumiaki Kinoshita
+
+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 Fumiaki Kinoshita 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
+ UI/PadKontrol.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes #-}
+module UI.PadKontrol (PadKontrol, runPadKontrol, module UI.PadKontrol.Types, module Control.Monad.IO.Class) where
+
+import qualified System.MIDI as MIDI
+import UI.PadKontrol.Types
+import Control.Applicative
+import Control.Monad.Operational.Mini
+import Control.Monad.IO.Class
+import Data.Word
+import qualified Data.Map as M
+import Data.Char
+
+type PadKontrol = Program Message
+
+instance MonadIO PadKontrol where
+    liftIO = singleton . LiftIO
+
+showHex :: Word8 -> String
+showHex n = intToDigit (fromEnum $ n `div` 16) : intToDigit (fromEnum $ n `mod` 16) : ""
+
+convertEvent :: MIDI.MidiEvent -> Maybe (Int, Event)
+convertEvent (MIDI.MidiEvent time (MIDI.SysEx msg)) = fmap ((,) (fromIntegral time)) $ case drop 4 msg of
+    [0x47, 0x00, 0x00] -> Just PedalUp
+    [0x47, 0x00, 0x7F] -> Just PedalDown
+    [0x45,s,t]
+        | s <= 0x0F -> Just $ PadUp (toEnum $ fromEnum s)
+        | s >= 0x40 -> Just $ PadDown (toEnum $ fromEnum (s - 0x40)) (fromIntegral (t - 0x30))
+    [0x48,0x20,0x7f] -> Just XYTouch
+    [0x48,0x20,0x00] -> Just XYRelease
+    [0x48,s,0x7f] -> Just $ ButtonDown $ toEnum $ fromEnum s
+    [0x48,s,0x00] -> Just $ ButtonUp $ toEnum $ fromEnum s
+    [0x49,0x00,v] -> Just $ Knob1 (fromIntegral v / 127)
+    [0x49,0x01,v] -> Just $ Knob2 (fromIntegral v / 127)
+    [0x4B,x,y] -> Just $ XYPad (fromIntegral x / 127) (fromIntegral y / 127)
+    [0x43,0x00,0x01] -> Just JogCW
+    [0x43,0x00,0x7F] -> Just JogCCW
+    [0x40,0x00,_] -> Nothing
+    [0x5f,_,_] -> Nothing
+    ev -> error $ "unknown message: " ++ show ev ++ " Please report this as a bug"
+convertEvent ev = error $ "unknown event: " ++ show ev
+
+runPadKontrol :: (Int -> Event -> Program Message ()) -> ((forall r. Program Message r -> IO r) -> IO a) -> IO a
+runPadKontrol handle m = do
+    let g getName = fmap M.fromList . mapM (liftA2 (,) <$> getName <*> return)
+    srcs <- MIDI.enumerateSources >>= g MIDI.getName
+    dests <- MIDI.enumerateDestinations >>= g MIDI.getName
+    let devSrc = srcs M.! "padKONTROL PORT A"
+        devDest = dests M.! "padKONTROL CTRL"
+    dest <- MIDI.openDestination devDest
+    src <- MIDI.openSource devSrc $ Just
+        $ interpret (eval dest) . maybe (return ()) (uncurry handle) . convertEvent
+    MIDI.start dest
+    MIDI.start src
+    MIDI.sendSysEx dest $ [0x42, 0x49, 0x6E, 0x08, 0x00, 0x00, 0x01]
+    MIDI.sendSysEx dest $ [0x42, 0x49, 0x6E, 0x08, 0x3F, 0x0A, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x29, 0x29, 0x29]
+    MIDI.sendSysEx dest $
+        [ 0x42, 0x49, 0x6E, 0x08, 0x3F, 0x2A, 0x00, 0x00
+        , 0x05, 0x05, 0x05, 0x7F, 0x7E, 0x7F, 0x7F, 0x03
+        , 0x0A, 0x0A, 0x0A, 0x0A, 0x0A, 0x0A, 0x0A, 0x0A
+        , 0x0A, 0x0A, 0x0A, 0x0A, 0x0A, 0x0A, 0x0A, 0x0A
+        , 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08
+        , 0x09, 0x0A, 0x0B, 0x0C, 0x0d, 0x0E, 0x0F, 0x10]
+    result <- m $ interpret (eval dest)
+    MIDI.sendSysEx dest $ [0x42, 0x40, 0x6E, 0x08, 0x00, 0x00, 0x00]
+    MIDI.stop src
+    MIDI.stop dest
+    MIDI.close src
+    MIDI.close dest
+    return result
+    where
+        light :: Light -> Word8
+        light Off = 0x00
+        light On = 0x20
+        light Blink = 0x63
+        light (Flash f) = 0x41 + floor (f * (0x5f - 0x41))
+
+        eval :: MIDI.Connection -> Message a -> IO a
+        eval dest (Display x y z) = send dest [0x22, 0x04, 0x00, x, y, z]
+        eval dest (DisplayBlink x y z) = send dest [0x22, 0x04, 0x01, x, y, z]
+        eval dest (DisplayLeft seg l) = send dest [0x01, 0xB8 + fromIntegral (fromEnum seg), light l]
+        eval dest (DisplayCenter seg l) = send dest [0x01, 0xB0 + fromIntegral (fromEnum seg), light l]
+        eval dest (DisplayRight seg l) = send dest [0x01, 0xA8 + fromIntegral (fromEnum seg), light l]
+        eval dest (PadLight p l) = send dest [0x01, 0x00 + fromIntegral (fromEnum p), light l]
+        eval dest (ButtonLight b l) = send dest [0x01, 0x10 + fromIntegral (fromEnum b), light l]
+        eval _ (LiftIO m) = m
+        eval dest (AllLight w x y z) = send dest [0x3F, 0x0A, 0x01, g0, g1, g2, g3, g4, 0x00, x, y, z]
+        　　where
+            g = foldr (flip $ flip (+) . (*2)) 0 . map (toEnum . fromEnum . w) 
+            g0 = g $ map Left [Pad01 .. Pad07]
+            g1 = g $ map Left [Pad08 .. Pad14]
+            g2 = g $ map Left [Pad15 .. Pad16] ++ map Right [ButtonScene ..ButtonMidiCh]
+            g3 = g $ map Right [ButtonSWType ..ButtonX]
+            g4 = g $ map Right [ButtonY .. ButtonHold]
+
+
+        send dest = MIDI.sendSysEx dest . ([0x42, 0x40, 0x6E, 0x08]++)
+ UI/PadKontrol/Types.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE GADTs, FlexibleContexts #-}
+module UI.PadKontrol.Types where
+import Data.Word
+import Control.Monad.Operational.Mini
+
+data Pad = Pad01 | Pad02 | Pad03 | Pad04
+         | Pad05 | Pad06 | Pad07 | Pad08
+         | Pad09 | Pad10 | Pad11 | Pad12
+         | Pad13 | Pad14 | Pad15 | Pad16
+          deriving (Show, Read, Eq, Ord, Enum)
+
+data Button = ButtonScene | ButtonMessage | ButtonSetting
+    | ButtonNoteCC | ButtonMidiCh | ButtonSWType | ButtonRelVal | ButtonVelocity | ButtonPort
+    | ButtonFixedVelocity | ButtonProgChange
+    | ButtonX | ButtonY | ButtonKnob1Assign | ButtonKnob2Assign | ButtonPedal
+    | ButtonRoll | ButtonFlam | ButtonHold deriving (Show, Read, Eq, Ord, Enum)
+
+data SevenSegment = SegTop
+    | SegUpperRight
+    | SegLowerRight
+    | SegBottom
+    | SegLowerLeft
+    | SegUpperLeft
+    | SegCenter
+    | SegPoint
+    deriving (Show, Read, Eq, Ord, Enum)
+
+data Light = Off | On | Blink | Flash Float
+
+data Message x where
+    Display :: Word8 -> Word8 -> Word8 -> Message ()
+    DisplayBlink :: Word8 -> Word8 -> Word8 -> Message ()
+    DisplayLeft :: SevenSegment -> Light -> Message ()
+    DisplayCenter :: SevenSegment -> Light -> Message ()
+    DisplayRight :: SevenSegment -> Light -> Message ()
+    PadLight :: Pad -> Light -> Message ()
+    ButtonLight :: Button -> Light -> Message ()
+    AllLight :: (Either Pad Button -> Bool) -> Word8 -> Word8 -> Word8 -> Message ()
+    LiftIO :: IO a -> Message a
+
+display :: Operational Message m => Word8 -> Word8 -> Word8 -> m ()
+display x y z = singleton $ Display x y z
+
+displayBlink :: Operational Message m => Word8 -> Word8 -> Word8 -> m ()
+displayBlink x y z = singleton $ DisplayBlink x y z
+
+displayLeft :: Operational Message m => SevenSegment -> Light -> m ()
+displayLeft s l = singleton $ DisplayLeft s l
+
+displayCenter :: Operational Message m => SevenSegment -> Light -> m ()
+displayCenter s l = singleton $ DisplayCenter s l
+
+displayRight :: Operational Message m => SevenSegment -> Light -> m ()
+displayRight s l = singleton $ DisplayRight s l
+
+padLight :: Operational Message m => Pad -> Light -> m ()
+padLight p l = singleton $ PadLight p l
+
+buttonLight :: Operational Message m => Button -> Light -> m ()
+buttonLight b l = singleton $ ButtonLight b l
+
+allLight :: Operational Message m => (Either Pad Button -> Bool) -> Word8 -> Word8 -> Word8 -> m ()
+allLight w x y z = singleton $ AllLight w x y z
+
+data Event = PadDown Pad Int
+    | PadUp Pad
+    | ButtonDown Button
+    | ButtonUp Button
+    | Knob1 Float
+    | Knob2 Float
+    | XYPad Float Float
+    | XYTouch
+    | XYRelease
+    | JogCW
+    | JogCCW
+    | PedalDown
+    | PedalUp
+    deriving Show
+ padKONTROL.cabal view
@@ -0,0 +1,21 @@+-- Initial padKONTROL.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                padKONTROL
+version:             0.1
+synopsis:            Controlling padKONTROL native mode
+-- description:         
+homepage:            https://github.com/fumieval/padKONTROL
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- copyright:           
+-- category:            
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     UI.PadKontrol, UI.PadKontrol.Types
+  -- other-modules:       
+  build-depends:       base ==4.*, hmidi ==0.*, minioperational ==0.1.*, transformers ==0.3.*, containers ==0.5.*