diff --git a/RELEASENOTES b/RELEASENOTES --- a/RELEASENOTES +++ b/RELEASENOTES @@ -1,7 +1,14 @@ Hackage: http://hackage.haskell.org/package/hArduino GitHub: http://leventerkok.github.com/hArduino -Latest Hackage released version: 0.1 +Latest Hackage released version: 0.2 + +====================================================================== +Version 0.2, 2013-01-28 + + - Rewrite the communication engine + - Digital input/output implementation + - Add switch example ====================================================================== Version 0.1, 2013-01-14 diff --git a/System/Hardware/Arduino.hs b/System/Hardware/Arduino.hs --- a/System/Hardware/Arduino.hs +++ b/System/Hardware/Arduino.hs @@ -29,7 +29,7 @@ -- ** Reading and Writing digital values , digitalRead, digitalWrite -- ** Misc utilities - , delay + , waitFor, delay -- * Hardware components on the board -- ** Pins , pin, PinMode(..) @@ -39,4 +39,3 @@ import System.Hardware.Arduino.Data import System.Hardware.Arduino.Comm import System.Hardware.Arduino.Firmata -import System.Hardware.Arduino.Parts diff --git a/System/Hardware/Arduino/Comm.hs b/System/Hardware/Arduino/Comm.hs --- a/System/Hardware/Arduino/Comm.hs +++ b/System/Hardware/Arduino/Comm.hs @@ -12,15 +12,21 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Comm where -import Control.Monad.State (modify, runStateT, when) +import Control.Monad (when, forever) +import Control.Concurrent (myThreadId, throwTo, newChan, newMVar, putMVar, writeChan, readChan, forkIO, modifyMVar_) +import Control.Exception (tryJust, AsyncException(UserInterrupt)) +import Control.Monad.State (runStateT, gets, liftIO, modify) +import Data.Bits (testBit) +import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch)) -import qualified Data.ByteString as B (pack, unpack, concat, length) +import qualified Data.ByteString as B (unpack, length) +import qualified Data.Map as M (empty, mapWithKey) +import qualified Data.Set as S (empty) import qualified System.Hardware.Serialport as S (withSerial, defaultSerialSettings, CommSpeed(CS57600), commSpeed, recv, send) import System.Hardware.Arduino.Data import System.Hardware.Arduino.Utils import System.Hardware.Arduino.Protocol -import System.Hardware.Arduino.Firmata -- | Run the Haskell program to control the board: -- @@ -39,46 +45,135 @@ -> Arduino () -- ^ The Haskell controller program to run -> IO () withArduino verbose fp program = - do debugger <- mkDebugPrinter verbose + do tid <- myThreadId + _ <- installHandler keyboardSignal (Catch (throwTo tid UserInterrupt)) Nothing + debugger <- mkDebugPrinter verbose debugger $ "Accessing arduino located at: " ++ show fp - let Arduino controller = do (v1, v2, m) <- queryFirmware - modify (\b -> b{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"}) + let Arduino controller = do initialize program S.withSerial fp S.defaultSerialSettings{S.commSpeed = S.CS57600} $ \port -> do - _ <- runStateT controller (mkState debugger port) - return () - where mkState debugger port = ArduinoState debugger port "ID: Uninitialized" (Just (ArduinoChannel recvChan recvNChan sendChan)) - where extract b = do let resp = unpackage b - debugger $ "Received: " ++ show resp - return resp - recvChan = do debugger "Waiting for a Sysex response.." - let skip = do b <- S.recv port 1 - case B.unpack b of - [] -> skip - [0xF0] -> return () - bs -> do debugger $ "Skipping bytes <" ++ unwords (map showByte bs) ++ ">" - skip - collect sofar = do b <- S.recv port 1 - let rmsg = b : sofar - if b == B.pack [0xF7] -- end message - then return $ reverse rmsg - else collect rmsg - skip - chunks <- collect [B.pack [0xF0]] - extract $ B.concat chunks - recvNChan n = do debugger $ "Waiting for a non-Sysex response of " ++ show n ++ " bytes" - let go need sofar - | need <= 0 = return sofar - | True = do b <- S.recv port need - case B.length b of - 0 -> go need sofar - l -> do when (need < l) $ debugger $ "Received partial response: <" ++ unwords (map showByte (B.unpack b)) ++ ">" - go (need - l) (b : sofar) - chunks <- go n [] - extract $ B.concat $ reverse chunks - sendChan msg = do let p = package msg - lp = B.length p - debugger $ "Sending: " ++ show msg ++ " <" ++ unwords (map showByte (B.unpack p)) ++ ">" - sent <- S.send port p - when (sent /= lp) - (debugger $ "Send failed. Tried: " ++ show lp ++ "bytes, reported: " ++ show sent) + let initBoardState = BoardState { + analogReportingPins = S.empty + , digitalReportingPins = S.empty + , pinStates = M.empty + , digitalWakeUpQueue = [] + } + bs <- newMVar initBoardState + dc <- newChan + let initState = ArduinoState { + message = debugger + , port = port + , firmataID = "Unknown" + , capabilities = BoardCapabilities M.empty + , boardState = bs + , deviceChannel = dc + } + res <- tryJust catchCtrlC $ runStateT controller initState + case res of + Left () -> putStrLn "hArduino: Caught Ctrl-C, quitting.." + _ -> return () + where catchCtrlC UserInterrupt = Just () + catchCtrlC _ = Nothing + +-- | Send down a request. +send :: Request -> Arduino () +send req = do debug $ "Sending: " ++ show req ++ " <" ++ unwords (map showByte (B.unpack p)) ++ ">" + serial <- gets port + sent <- liftIO $ S.send serial p + when (sent /= lp) + (debug $ "Send failed. Tried: " ++ show lp ++ "bytes, reported: " ++ show sent) + where p = package req + lp = B.length p + +-- | Receive a sys-ex response. This is a blocking call. +recv :: Arduino Response +recv = do ch <- gets deviceChannel + liftIO $ readChan ch + +-- | Start a thread to listen to the board and populate the channel with incoming queries. +-- NB. This function is run in a thread; so be careful not to throw error or die otherwise +-- in here. +setupListener :: Arduino () +setupListener = do + serial <- gets port + dbg <- gets message + chan <- gets deviceChannel + let getBytes n = do let go need sofar + | need <= 0 = return $ reverse sofar + | True = do b <- S.recv serial need + case B.length b of + 0 -> go need sofar + l -> go (need - l) (b : sofar) + chunks <- go n [] + return $ concatMap B.unpack chunks + collectSysEx sofar = do [b] <- getBytes 1 + if b == firmataCmdVal END_SYSEX + then return $ reverse sofar + else collectSysEx (b : sofar) + listener bs = do + [cmd] <- getBytes 1 + resp <- case getFirmataCmd cmd of + Left unknown -> return $ Unimplemented (Just (show unknown)) [] + Right START_SYSEX -> unpackageSysEx `fmap` collectSysEx [] + Right nonSysEx -> unpackageNonSysEx getBytes nonSysEx + case resp of + Unimplemented{} -> dbg $ "Ignoring the received response: " ++ show resp + DigitalMessage p l h -> do dbg $ "Updating port " ++ show p ++ " values with " ++ showByteList [l,h] + modifyMVar_ bs $ \bst -> do + let upd o od | p /= pinPort o = od -- different port, no change + | pinMode od `notElem` [INPUT] = od -- not an input pin, ignore + | True = od{pinValue = Just (Left newVal)} + where idx = pinPortIndex o + newVal | idx <= 6 = l `testBit` fromIntegral idx + | True = h `testBit` fromIntegral (idx - 7) + let wakeUpQ = digitalWakeUpQueue bst + bst' = bst{ pinStates = M.mapWithKey upd (pinStates bst) + , digitalWakeUpQueue = [] + } + mapM_ (`putMVar` ()) wakeUpQ + return bst' + _ -> do dbg $ "Received " ++ show resp + writeChan chan resp + bs <- gets boardState + tid <- liftIO $ forkIO $ forever (listener bs) + debug $ "Started listener thread: " ++ show tid + +-- | Initialize our board, get capabilities, etc +initialize :: Arduino () +initialize = do + -- Step 1: Set up the listener thread + setupListener + -- Step 2: Send query-firmware, and wait until we get a response + handshake QueryFirmware + (\r -> case r of {Firmware{} -> True; _ -> False}) + (\(Firmware v1 v2 m) -> modify (\s -> s{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"})) + -- Step 3: Send a capabilities request + handshake CapabilityQuery + (\r -> case r of {Capabilities{} -> True; _ -> False}) + (\(Capabilities c) -> modify (\s -> s{capabilities = c})) + -- Step 4: Send analog-mapping query + handshake AnalogMappingQuery + (\r -> case r of {AnalogMapping{} -> True; _ -> False}) + (\(AnalogMapping bs) -> do BoardCapabilities m <- gets capabilities + modify (\s -> s{capabilities = BoardCapabilities (M.mapWithKey (mapAnalog bs) m)})) + -- We're done, print capabilities in debug mode + cs <- gets capabilities + dbg <- gets message + liftIO $ dbg $ "Handshake complete. Board capabilities:\n" ++ show cs + where handshake msg isOK process = do + dbg <- gets message + send msg + let wait = do resp <- recv + if isOK resp + then process resp + else do liftIO $ dbg $ "Skpping unexpected response: " ++ show resp + wait + wait + mapAnalog bs p c + | i < rl && m /= 0x7f + = (Just m, snd c) + | True -- out-of-bounds, or not analog; ignore + = c + where rl = length bs + i = fromIntegral (pinNo p) + m = bs !! i diff --git a/System/Hardware/Arduino/Data.hs b/System/Hardware/Arduino/Data.hs --- a/System/Hardware/Arduino/Data.hs +++ b/System/Hardware/Arduino/Data.hs @@ -14,52 +14,339 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Data where -import Control.Monad.State (StateT, MonadIO, MonadState, gets, liftIO) -import Data.Maybe (fromMaybe) -import System.Hardware.Serialport (SerialPort) +import Control.Applicative (Applicative) +import Control.Concurrent (Chan, MVar, modifyMVar, modifyMVar_, readMVar) +import Control.Monad.State (StateT, MonadIO, MonadState, gets, liftIO) +import Data.Bits ((.&.), (.|.), setBit) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Word (Word8) +import System.Hardware.Serialport (SerialPort) -import System.Hardware.Arduino.Protocol +import qualified Data.Map as M +import qualified Data.Set as S --- | Basic communication channel with the board. -data ArduinoChannel = ArduinoChannel { - recvChan :: IO Response -- ^ Receive a sys-ex response. - , recvNChan :: Int -> IO Response -- ^ Receive a non-sys-ex response that has /n/ bytes in it - , sendChan :: Request -> IO () -- ^ Send a request down to Arduino - } +import System.Hardware.Arduino.Utils --- | State of the board and other machinery. +-- | A port (containing 8 pins) +data Port = Port { portNo :: Word8 -- ^ The port number + } + deriving (Eq, Ord) + +instance Show Port where + show p = "Port" ++ show (portNo p) + +-- | A pin on the Arduino +data Pin = Pin { pinNo :: Word8 -- ^ The pin number + } + deriving (Eq, Ord) + +instance Show Pin where + show p | i < 10 = "Pin0" ++ show i + | True = "Pin" ++ show i + where i = pinNo p + +-- | Declare a pin on the board by its number. +pin :: Word8 -> Pin +pin = Pin + +-- | On the Arduino, pins are grouped into banks of 8. +-- Given a pin, this function determines which port it belongs to +pinPort :: Pin -> Port +pinPort p = Port (pinNo p `quot` 8) + +-- | On the Arduino, pins are grouped into banks of 8. +-- Given a pin, this function determines which index it belongs to in its port +pinPortIndex :: Pin -> Word8 +pinPortIndex p = pinNo p `rem` 8 + +-- | The mode for a pin. +data PinMode = INPUT -- ^ Digital input + | OUTPUT -- ^ Digital output + | ANALOG -- ^ Analog input + | PWM -- ^ PWM (Pulse-Width-Modulation) output + | SERVO -- ^ Servo Motor controller + | SHIFT -- ^ Shift controller + | I2C -- ^ I2C (Inter-Integrated-Circuit) connection + deriving (Eq, Show, Enum) + +-- | A request, as sent to Arduino +data Request = QueryFirmware -- ^ Query the Firmata version installed + | CapabilityQuery -- ^ Query the capabilities of the board + | AnalogMappingQuery -- ^ Query the mapping of analog pins + | SetPinMode Pin PinMode -- ^ Set the mode on a pin + | DigitalReport Port Bool -- ^ Digital report values on port enable/disable + | AnalogReport Pin Bool -- ^ Analog report values on pin enable/disable + | DigitalPortWrite Port Word8 Word8 -- ^ Set the values on a port digitally + deriving Show + +-- | A response, as returned from the Arduino +data Response = Firmware Word8 Word8 String -- ^ Firmware version (maj/min and indentifier + | Capabilities BoardCapabilities -- ^ Capabilities report + | AnalogMapping [Word8] -- ^ Analog pin mappings + | DigitalMessage Port Word8 Word8 -- ^ Status of a port + | Unimplemented (Maybe String) [Word8] -- ^ Represents messages currently unsupported + +instance Show Response where + show (Firmware majV minV n) = "Firmware v" ++ show majV ++ "." ++ show minV ++ " (" ++ n ++ ")" + show (Capabilities b) = "Capabilities:\n" ++ show b + show (AnalogMapping bs) = "AnalogMapping: " ++ showByteList bs + show (DigitalMessage p l h) = "DigitalMessage " ++ show p ++ " = " ++ showByte l ++ " " ++ showByte h + show (Unimplemented mbc bs) = "Unimplemeneted " ++ fromMaybe "" mbc ++ " " ++ showByteList bs + +-- | Resolution, as referred to in http://firmata.org/wiki/Protocol#Capability_Query +-- TODO: Not quite sure how this is used, so merely keep it as a Word8 now +type Resolution = Word8 + +-- | Capabilities of a pin +type PinCapabilities = ( Maybe Word8 -- Analog pin number, if any + , [(PinMode, Resolution)] + ) + +-- | What the board is capable of and current settings +newtype BoardCapabilities = BoardCapabilities (M.Map Pin PinCapabilities) + +instance Show BoardCapabilities where + show (BoardCapabilities m) = intercalate "\n" (map sh (M.toAscList m)) + where sh (p, (mbA, pc)) = show p ++ sep ++ unwords [show md | (md, _) <- pc] + where sep = maybe ": " (\i -> "[A" ++ show i ++ "]: ") mbA + +-- | Data associated with a pin +data PinData = PinData { + pinMode :: PinMode + , pinValue :: Maybe (Either Bool Int) + } + deriving Show + +-- | State of the board +data BoardState = BoardState { + analogReportingPins :: S.Set Pin -- ^ Which analog pins are reporting + , digitalReportingPins :: S.Set Pin -- ^ Which digital pins are reporting + , pinStates :: M.Map Pin PinData -- ^ For-each pin, store its data + , digitalWakeUpQueue :: [MVar ()] -- ^ Semaphore list to wake-up upon receiving a digital message for this pin + } + +-- | State of the computation data ArduinoState = ArduinoState { - message :: String -> IO () -- ^ Current debugging routine - , port :: SerialPort -- ^ Port we are communicating on - , firmataID :: String -- ^ The ID of the board (as identified by the Board itself) - , deviceChannel :: Maybe ArduinoChannel -- ^ Communication channel + message :: String -> IO () -- ^ Current debugging routine + , port :: SerialPort -- ^ Serial port we are communicating on + , firmataID :: String -- ^ The ID of the board (as identified by the Board itself) + , capabilities :: BoardCapabilities -- ^ Capabilities of the board + , boardState :: MVar BoardState -- ^ Current state of the board + , deviceChannel :: Chan Response -- ^ Incoming messages from the board } -- | The Arduino monad. newtype Arduino a = Arduino (StateT ArduinoState IO a) - deriving (Functor, Monad, MonadIO, MonadState ArduinoState) + deriving (Functor, Applicative, Monad, MonadIO, MonadState ArduinoState) --- | Retrieve the current channel. -getChannel :: Arduino ArduinoChannel -getChannel = fromMaybe die `fmap` gets deviceChannel - where die = error "Cannot communicate with the board!" +-- | Debugging only: print the given string on stdout. +debug :: String -> Arduino () +debug s = do f <- gets message + liftIO $ f s --- | Send down a request. -send :: Request -> Arduino () -send r = do ArduinoChannel{sendChan} <- getChannel - liftIO $ sendChan r +-- | Which modes does this pin support? +getPinModes :: Pin -> Arduino [PinMode] +getPinModes p = do + BoardCapabilities caps <- gets capabilities + case p `M.lookup` caps of + Nothing -> return [] + Just (_, ps) -> return (map fst ps) --- | Receive a sys-ex response. -recv :: Arduino Response -recv = do ArduinoChannel{recvChan} <- getChannel - liftIO recvChan +-- | Current state of the pin +getPinData :: Pin -> Arduino PinData +getPinData p = do + bs <- gets boardState + bst <- liftIO $ readMVar bs + case p `M.lookup` pinStates bst of + Nothing -> die ("Trying to access " ++ show p ++ " without proper configuration.") + ["Make sure that you use 'setPinMode' to configure this pin first."] + Just pd -> return pd --- | Receive a non-sys-ex response, that has /n/ bytes -recvN :: Int -> Arduino Response -recvN n = do ArduinoChannel{recvNChan} <- getChannel - liftIO $ recvNChan n +-- | Given a pin, collect the digital value corresponding to the +-- port it belongs to, where the new value of the current pin is given +-- The result is two bytes: +-- +-- * First lsb: pins 0-6 on the port +-- * Second msb: pins 7-13 on the port +-- +-- In particular, the result is suitable to be sent with a digital message +computePortData :: Pin -> Bool -> Arduino (Word8, Word8) +computePortData curPin newValue = do + let curPort = pinPort curPin + let curIndex = pinPortIndex curPin + bs <- gets boardState + liftIO $ modifyMVar bs $ \bst -> do + let values = [(pinPortIndex p, pinValue pd) | (p, pd) <- M.assocs (pinStates bst), curPort == pinPort p, pinMode pd `elem` [INPUT, OUTPUT]] + getVal i + | i == curIndex = newValue + | Just (Just (Left v)) <- i `lookup` values = v + | True = False + [b0, b1, b2, b3, b4, b5, b6, b7] = map getVal [0 .. 7] + lsb = foldr (\(i, b) m -> if b then m `setBit` i else m) 0 (zip [0..] [b0, b1, b2, b3, b4, b5, b6]) + msb = foldr (\(i, b) m -> if b then m `setBit` (i-7) else m) 0 (zip [7..] [b7]) + -- update internal-value of the pin + let bst' = bst {pinStates = M.insertWith (\_ o -> o{pinValue = Just (Left newValue)}) + curPin + PinData{pinMode = OUTPUT, pinValue = Just (Left newValue)} + (pinStates bst)} + return (bst', (lsb, msb)) --- | Debugging only: print it on stdout. -debug :: String -> Arduino () -debug s = do f <- gets message - liftIO $ f s +-- | Keep track of listeners on a digital message +digitalWakeUp :: MVar () -> Arduino () +digitalWakeUp semaphore = do + bs <- gets boardState + liftIO $ modifyMVar_ bs $ \bst -> return bst{digitalWakeUpQueue = semaphore : digitalWakeUpQueue bst} + +-- | Firmata commands, see: http://firmata.org/wiki/Protocol#Message_Types +data FirmataCmd = ANALOG_MESSAGE Pin -- ^ @0xE0@ pin + | DIGITAL_MESSAGE Port -- ^ @0x90@ port + | REPORT_ANALOG_PIN Pin -- ^ @0xC0@ pin + | REPORT_DIGITAL_PORT Port -- ^ @0xD0@ port + | START_SYSEX -- ^ @0xF0@ + | SET_PIN_MODE -- ^ @0xF4@ + | END_SYSEX -- ^ @0xF7@ + | PROTOCOL_VERSION -- ^ @0xF9@ + | SYSTEM_RESET -- ^ @0xFF@ + deriving Show + +-- | Compute the numeric value of a command +firmataCmdVal :: FirmataCmd -> Word8 +firmataCmdVal (ANALOG_MESSAGE p) = 0xE0 .|. pinNo p +firmataCmdVal (DIGITAL_MESSAGE p) = 0x90 .|. portNo p +firmataCmdVal (REPORT_ANALOG_PIN p) = 0xC0 .|. pinNo p +firmataCmdVal (REPORT_DIGITAL_PORT p) = 0xD0 .|. portNo p +firmataCmdVal START_SYSEX = 0xF0 +firmataCmdVal SET_PIN_MODE = 0xF4 +firmataCmdVal END_SYSEX = 0xF7 +firmataCmdVal PROTOCOL_VERSION = 0xF9 +firmataCmdVal SYSTEM_RESET = 0xFF + +-- | Convert a byte to a Firmata command +getFirmataCmd :: Word8 -> Either Word8 FirmataCmd +getFirmataCmd w = classify + where extract m | w .&. m == m = Just $ fromIntegral (w .&. 0x0F) + | True = Nothing + classify | w == 0xF0 = Right START_SYSEX + | w == 0xF4 = Right SET_PIN_MODE + | w == 0xF7 = Right END_SYSEX + | w == 0xF9 = Right PROTOCOL_VERSION + | w == 0xFF = Right SYSTEM_RESET + | Just i <- extract 0xE0 = Right $ ANALOG_MESSAGE (Pin i) + | Just i <- extract 0x90 = Right $ DIGITAL_MESSAGE (Port i) + | Just i <- extract 0xC0 = Right $ REPORT_ANALOG_PIN (Pin i) + | Just i <- extract 0xD0 = Right $ REPORT_DIGITAL_PORT (Port i) + | True = Left w + +-- | Sys-ex commands, see: http://firmata.org/wiki/Protocol#Sysex_Message_Format +data SysExCmd = RESERVED_COMMAND -- ^ @0x00@ 2nd SysEx data byte is a chip-specific command (AVR, PIC, TI, etc). + | ANALOG_MAPPING_QUERY -- ^ @0x69@ ask for mapping of analog to pin numbers + | ANALOG_MAPPING_RESPONSE -- ^ @0x6A@ reply with mapping info + | CAPABILITY_QUERY -- ^ @0x6B@ ask for supported modes and resolution of all pins + | CAPABILITY_RESPONSE -- ^ @0x6C@ reply with supported modes and resolution + | PIN_STATE_QUERY -- ^ @0x6D@ ask for a pin's current mode and value + | PIN_STATE_RESPONSE -- ^ @0x6E@ reply with a pin's current mode and value + | EXTENDED_ANALOG -- ^ @0x6F@ analog write (PWM, Servo, etc) to any pin + | SERVO_CONFIG -- ^ @0x70@ set max angle, minPulse, maxPulse, freq + | STRING_DATA -- ^ @0x71@ a string message with 14-bits per char + | SHIFT_DATA -- ^ @0x75@ shiftOut config/data message (34 bits) + | I2C_REQUEST -- ^ @0x76@ I2C request messages from a host to an I/O board + | I2C_REPLY -- ^ @0x77@ I2C reply messages from an I/O board to a host + | I2C_CONFIG -- ^ @0x78@ Configure special I2C settings such as power pins and delay times + | REPORT_FIRMWARE -- ^ @0x79@ report name and version of the firmware + | SAMPLING_INTERVAL -- ^ @0x7A@ sampling interval + | SYSEX_NON_REALTIME -- ^ @0x7E@ MIDI Reserved for non-realtime messages + | SYSEX_REALTIME -- ^ @0x7F@ MIDI Reserved for realtime messages + deriving Show + +-- | Convert a 'SysExCmd' to a byte +sysExCmdVal :: SysExCmd -> Word8 +sysExCmdVal RESERVED_COMMAND = 0x00 +sysExCmdVal ANALOG_MAPPING_QUERY = 0x69 +sysExCmdVal ANALOG_MAPPING_RESPONSE = 0x6A +sysExCmdVal CAPABILITY_QUERY = 0x6B +sysExCmdVal CAPABILITY_RESPONSE = 0x6C +sysExCmdVal PIN_STATE_QUERY = 0x6D +sysExCmdVal PIN_STATE_RESPONSE = 0x6E +sysExCmdVal EXTENDED_ANALOG = 0x6F +sysExCmdVal SERVO_CONFIG = 0x70 +sysExCmdVal STRING_DATA = 0x71 +sysExCmdVal SHIFT_DATA = 0x75 +sysExCmdVal I2C_REQUEST = 0x76 +sysExCmdVal I2C_REPLY = 0x77 +sysExCmdVal I2C_CONFIG = 0x78 +sysExCmdVal REPORT_FIRMWARE = 0x79 +sysExCmdVal SAMPLING_INTERVAL = 0x7A +sysExCmdVal SYSEX_NON_REALTIME = 0x7E +sysExCmdVal SYSEX_REALTIME = 0x7F + +-- | Convert a byte into a 'SysExCmd' +getSysExCommand :: Word8 -> Either Word8 SysExCmd +getSysExCommand 0x00 = Right RESERVED_COMMAND +getSysExCommand 0x69 = Right ANALOG_MAPPING_QUERY +getSysExCommand 0x6A = Right ANALOG_MAPPING_RESPONSE +getSysExCommand 0x6B = Right CAPABILITY_QUERY +getSysExCommand 0x6C = Right CAPABILITY_RESPONSE +getSysExCommand 0x6D = Right PIN_STATE_QUERY +getSysExCommand 0x6E = Right PIN_STATE_RESPONSE +getSysExCommand 0x6F = Right EXTENDED_ANALOG +getSysExCommand 0x70 = Right SERVO_CONFIG +getSysExCommand 0x71 = Right STRING_DATA +getSysExCommand 0x75 = Right SHIFT_DATA +getSysExCommand 0x76 = Right I2C_REQUEST +getSysExCommand 0x77 = Right I2C_REPLY +getSysExCommand 0x78 = Right I2C_CONFIG +getSysExCommand 0x79 = Right REPORT_FIRMWARE +getSysExCommand 0x7A = Right SAMPLING_INTERVAL +getSysExCommand 0x7E = Right SYSEX_NON_REALTIME +getSysExCommand 0x7F = Right SYSEX_REALTIME +getSysExCommand n = Left n + +-- | Keep track of pin-mode changes +registerPinMode :: Pin -> PinMode -> Arduino [Request] +registerPinMode p m = do + -- first check that the requested mode is supported for this pin + BoardCapabilities caps <- gets capabilities + case p `M.lookup` caps of + Nothing + -> die ("Invalid access to unsupported pin: " ++ show p) + ("Available pins are: " : [" " ++ show k | (k, _) <- M.toAscList caps]) + Just (_, ms) + | m `notElem` map fst ms + -> die ("Invalid mode " ++ show m ++ " set for " ++ show p) + ["Supported modes for this pin are: " ++ unwords (if null ms then ["NONE"] else map show ms)] + _ -> return () + -- register the pin mode + bs <- gets boardState + liftIO $ modifyMVar_ bs $ \bst -> return bst{pinStates = M.insert p PinData{pinMode = m, pinValue = Nothing} (pinStates bst) } + -- now return extra actions we need to take for this mode + getModeActions p m + +-- | Depending on a mode-set call, determine what further +-- actions should be executed, such as enabling/disabling pin/port reporting +getModeActions :: Pin -> PinMode -> Arduino [Request] +getModeActions p INPUT = do -- This pin is just configured for digital input + bs <- gets boardState + liftIO $ modifyMVar bs $ \bst -> do + let aPins = analogReportingPins bst + dPins = digitalReportingPins bst + port = pinPort p + acts1 = [AnalogReport p False | p `S.member` aPins] -- there was an analog report, remove it + acts2 = [DigitalReport port True | port `notElem` map pinPort (S.elems dPins)] -- there was no digital report, add it + bst' = bst { analogReportingPins = p `S.delete` analogReportingPins bst + , digitalReportingPins = p `S.insert` digitalReportingPins bst + } + return (bst', acts1 ++ acts2) +getModeActions p ANALOG = do -- This pin just configured for analog + bs <- gets boardState + liftIO $ modifyMVar bs $ \bst -> do + let aPins = analogReportingPins bst + dPins = p `S.delete` digitalReportingPins bst + port = pinPort p + acts1 = [AnalogReport p True | p `S.notMember` aPins] -- there was no analog report, add it + acts2 = [DigitalReport port False | port `notElem` map pinPort (S.elems dPins)] -- no need for a digital report, remove it + bst' = bst { analogReportingPins = p `S.insert` analogReportingPins bst + , digitalReportingPins = dPins + } + return (bst', acts1 ++ acts2) +getModeActions _ _ = return [] diff --git a/System/Hardware/Arduino/Examples/Blink.hs b/System/Hardware/Arduino/Examples/Blink.hs --- a/System/Hardware/Arduino/Examples/Blink.hs +++ b/System/Hardware/Arduino/Examples/Blink.hs @@ -13,6 +13,8 @@ import Control.Monad (forever) import Control.Monad.Trans (liftIO) +import System.IO (hSetBuffering, BufferMode(NoBuffering), stdout) + import System.Hardware.Arduino -- | Blink the led connected to port 13 on the Arduino UNO board. @@ -24,6 +26,7 @@ -- a useful diagnostic message. blink :: IO () blink = withArduino False "/dev/cu.usbmodemfd131" $ do + liftIO $ hSetBuffering stdout NoBuffering let led = pin 13 setPinMode led OUTPUT forever $ do liftIO $ putStr "." diff --git a/System/Hardware/Arduino/Examples/Switch.hs b/System/Hardware/Arduino/Examples/Switch.hs new file mode 100644 --- /dev/null +++ b/System/Hardware/Arduino/Examples/Switch.hs @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------- +-- | +-- Module : System.Hardware.Arduino.Examples.Switch +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Reads the value of a push-button switch and displays it continuously +------------------------------------------------------------------------------- + +module System.Hardware.Arduino.Examples.Switch where + +import Control.Monad.Trans (liftIO) +import System.IO (hSetBuffering, BufferMode(NoBuffering), stdout) + +import System.Hardware.Arduino + +-- | Read the value of a push-button switch (NO - normally open) +-- connected to input pin 2 on the Arduino. We will continuously +-- monitor and print the value as it changes. Also, we'll turn +-- the led on pin 7 on when the switch is pressed. +-- +-- The wiring diagram is fairly straightforward: +-- +-- Switch: ~10K pull-down resistor, between pin 2 and GND +-- Push-button NO-switch (normally open) between pin-2 and 5V +-- +-- Led : ~10K pull-down resistor between pin-7 and led+ +-- Led between GND and the resistor +-- +-- Don't neglect the resistors to make sure you don't do a short-circuit! +switch :: IO () +switch = withArduino False "/dev/cu.usbmodemfd131" $ do + liftIO $ hSetBuffering stdout NoBuffering + setPinMode led OUTPUT + setPinMode button INPUT + current <- digitalRead button + report (not current) current + go current + where button = pin 2 + led = pin 7 + report prev new + | prev /= new = do liftIO $ putStrLn $ "Button is currently " ++ if new then "ON" else "OFF" + digitalWrite led new + | True = return () + go prev = do new <- waitFor button + report prev new + go new diff --git a/System/Hardware/Arduino/Firmata/Basics.hs b/System/Hardware/Arduino/Firmata/Basics.hs --- a/System/Hardware/Arduino/Firmata/Basics.hs +++ b/System/Hardware/Arduino/Firmata/Basics.hs @@ -12,13 +12,13 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Firmata.Basics where +import Control.Concurrent (newEmptyMVar, readMVar) +import Control.Monad (when) import Control.Monad.Trans (liftIO) import Data.Word (Word8) -import Data.Bits (shiftL) import System.Hardware.Arduino.Data -import System.Hardware.Arduino.Parts -import System.Hardware.Arduino.Protocol +import System.Hardware.Arduino.Comm import qualified System.Hardware.Arduino.Utils as U -- | Retrieve the Firmata firmware version running on the Arduino. The first @@ -30,36 +30,64 @@ r <- recv case r of Firmware v1 v2 m -> return (v1, v2, m) - _ -> error $ "Got unexpected response for query firmware call: " ++ show r + _ -> error $ "queryFirmware: Got unexpected response for query firmware call: " ++ show r --- | Delay the computaton for a given number of milli-seconds. +-- | Delay the computaton for a given number of milli-seconds delay :: Int -> Arduino () delay = liftIO . U.delay --- | Set the mode on a particular pin on the board. +-- | Set the mode on a particular pin on the board setPinMode :: Pin -> PinMode -> Arduino () -setPinMode p m = send $ SetPinMode p m - --- | Read the value of a pin in digital mode. -digitalRead :: Pin -> Arduino (PinMode, Bool) -digitalRead p = do - send $ DigitalRead p - r <- recv - case r of - DigitalPinState p' m b -> if p == p' - then return (m, b) - else error $ "Got unexpected response for " ++ show p' ++ " instead of " ++ show p - _ -> error $ "Got unexpected response for query DigitalRead: " ++ show r +setPinMode p m = do + extras <- registerPinMode p m + send $ SetPinMode p m + mapM_ send extras --- | Set or clear a particular digital pin on the board. +-- | Set or clear a digital pin on the board digitalWrite :: Pin -> Bool -> Arduino () digitalWrite p v = do - let (port, idx) = pinPort p - dr n - | n > 2 && n < 14 = digitalRead (pin n) - | True = return (OUTPUT, False) - oldVal <- map snd `fmap` mapM dr [port * 8 + i | i <- [0 .. 7]] - let [b0, b1, b2, b3, b4, b5, b6, b7] = [if i == idx then v else old | (old, i) <- zip oldVal [0 ..]] - lsb = sum [1 `shiftL` i | (True, i) <- zip [b0, b1, b2, b3, b4, b5, b6, False] [0 .. 7]] - msb = if b7 then 1 else 0 - send $ DigitalPortWrite port lsb msb + -- first make sure we have this pin set as output + pd <- getPinData p + when (pinMode pd /= OUTPUT) $ U.die ("Invalid digitalWrite call on pin " ++ show p) + [ "The current mode for this pin is: " ++ show (pinMode pd) + , "For digitalWrite, it must be set to: " ++ show OUTPUT + , "via a proper call to setPinMode" + ] + (lsb, msb) <- computePortData p v + send $ DigitalPortWrite (pinPort p) lsb msb + +-- | Read the value of a pin in digital mode; this is a non-blocking call, returning +-- the current value immediately. See 'waitFor' for a version that waits for a change +-- in the pin first. +digitalRead :: Pin -> Arduino Bool +digitalRead p = do + -- first make sure we have this pin set as input + pd <- getPinData p + when (pinMode pd /= INPUT) $ U.die ("Invalid digitalRead call on pin " ++ show p) + [ "The current mode for this pin is: " ++ show (pinMode pd) + , "For digitalWrite, it must be set to: " ++ show INPUT + , "via a proper call to setPinMode" + ] + return $ case pinValue pd of + Just (Left v) -> v + _ -> False -- no (correctly-typed) value reported yet, default to False + +-- | Wait for a change in the value of the digital input pin. Returns the new value. +-- Note that this is a blocking call. For a non-blocking version, see 'digitalRead', which returns the current +-- value of a pin immediately. +waitFor :: Pin -> Arduino Bool +waitFor p = do + curVal <- digitalRead p + let wait = do sleepTillDigitalMessage + newVal <- digitalRead p + if newVal == curVal + then wait + else return newVal + wait + +-- | Sleep until we receive a digital message from the board +sleepTillDigitalMessage :: Arduino () +sleepTillDigitalMessage = do + semaphore <- liftIO newEmptyMVar + digitalWakeUp semaphore + liftIO $ readMVar semaphore diff --git a/System/Hardware/Arduino/Parts.hs b/System/Hardware/Arduino/Parts.hs deleted file mode 100644 --- a/System/Hardware/Arduino/Parts.hs +++ /dev/null @@ -1,45 +0,0 @@ -------------------------------------------------------------------------------- --- | --- Module : System.Hardware.Arduino.Firmata.Parts --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Basic Arduino hardware abstractions, pins etc. -------------------------------------------------------------------------------- - -module System.Hardware.Arduino.Parts(PinMode(..), Pin, pin, pinNo, pinPort) where - --- | A pin on the Arduino -data Pin = Pin { pinNo :: Int -- ^ The pin number - } - deriving Eq - -instance Show Pin where - show p | i < 10 = "Pin0" ++ show i - | True = "Pin" ++ show i - where i = pinNo p - --- | Smart constructor for a pin. The input should be between 1 and 13: --- --- * Pins 0-1 are reserved for TX/RX; so can't be directly used. --- --- * 13 pins is UNO specific, we will need to expand this definition if --- we start supporting other boards. -pin :: Int -> Pin -pin i | i < 2 || i > 13 = error $ "Invalid pin number: " ++ show i - | True = Pin i - --- | On the Arduino, pins are grouped into banks of 8. --- Given a pin, this function determines which port/index it belongs to -pinPort :: Pin -> (Int, Int) -pinPort p = pinNo p `quotRem` 8 - --- | The mode for a pin. -data PinMode = INPUT - | OUTPUT - | ANALOG - | PWM - | SERVO - deriving (Show, Enum) diff --git a/System/Hardware/Arduino/Protocol.hs b/System/Hardware/Arduino/Protocol.hs --- a/System/Hardware/Arduino/Protocol.hs +++ b/System/Hardware/Arduino/Protocol.hs @@ -9,89 +9,70 @@ -- Internal representation of the firmata protocol. ------------------------------------------------------------------------------- -module System.Hardware.Arduino.Protocol(Request(..), Response(..), package, unpackage) where +module System.Hardware.Arduino.Protocol(package, unpackageSysEx, unpackageNonSysEx) where -import Data.Bits ((.|.), (.&.), shiftL) -import Data.Char (chr) -import Data.List (intercalate) -import Data.Word (Word8, Word16) +import Data.Word (Word8) import qualified Data.ByteString as B +import qualified Data.Map as M -import System.Hardware.Arduino.Parts +import System.Hardware.Arduino.Data import System.Hardware.Arduino.Utils --- | A request, as sent to Arduino -data Request = QueryFirmware -- ^ Query the Firmata version installed - | SetPinMode Pin PinMode -- ^ Set a pin to a particular mode - | DigitalRead Pin -- ^ Read the value of a given pin - | DigitalPortWrite Int Word8 Word8 -- ^ Write the values of pins on the given port; 2 bytes lo/hi - -instance Show Request where - show QueryFirmware = "QueryFirmWare" - show (SetPinMode p m) = "SetPinMode " ++ show p ++ " to " ++ show m - show (DigitalRead p) = "DigitalRead " ++ show p - show (DigitalPortWrite p l h) = "DigitalWrite " ++ show p ++ " to " ++ showBin l ++ "_" ++ showBin h - --- | A response, as returned from the Arduino -data Response = Firmware Word8 Word8 String -- ^ Firmware version (maj/min and indentifier - | DigitalPinState Pin PinMode Bool -- ^ State of a given pin - | DigitalPortState Int Word16 -- ^ State of a given port - | Unknown [Word8] -- ^ Represents messages currently unsupported - -instance Show Response where - show (Firmware majV minV n) = "Firmware v" ++ show majV ++ "." ++ show minV ++ " (" ++ n ++ ")" - show (DigitalPinState p m v) = "DigitalPinState " ++ show p ++ "(" ++ show m ++ ") = " ++ if v then "HIGH" else "LOW" - show (DigitalPortState p w) = "DigitalPortState " ++ show p ++ " = " ++ show w - show (Unknown bs) = "Unknown [" ++ intercalate ", " (map showByte bs) ++ "]" - --- | Marker for the start of a sys-ex message -cdStart :: Word8 -cdStart = 0xf0 - --- | Marker for the end of a sys-ex message -cdEnd :: Word8 -cdEnd = 0xf7 - -- | Wrap a sys-ex message to be sent to the board -sysEx :: [Word8] -> B.ByteString -sysEx bs = B.pack $ cdStart : bs ++ [cdEnd] +sysEx :: SysExCmd -> [Word8] -> B.ByteString +sysEx cmd bs = B.pack $ firmataCmdVal START_SYSEX + : sysExCmdVal cmd + : bs + ++ [firmataCmdVal END_SYSEX] +-- | Construct a non sys-ex message +nonSysEx :: FirmataCmd -> [Word8] -> B.ByteString +nonSysEx cmd bs = B.pack $ firmataCmdVal cmd : bs + -- | Package a request as a sequence of bytes to be sent to the board -- using the Firmata protocol. package :: Request -> B.ByteString -package QueryFirmware = sysEx [0x79] -package (SetPinMode p m) = B.pack [0xf4, fromIntegral (pinNo p), fromIntegral (fromEnum m)] -package (DigitalRead p) = sysEx [0x6d, fromIntegral (pinNo p)] -package (DigitalPortWrite p l m) = B.pack [0x90 .|. fromIntegral p, l, m] +package QueryFirmware = sysEx REPORT_FIRMWARE [] +package CapabilityQuery = sysEx CAPABILITY_QUERY [] +package AnalogMappingQuery = sysEx ANALOG_MAPPING_QUERY [] +package (AnalogReport p b) = nonSysEx (REPORT_ANALOG_PIN p) [if b then 1 else 0] +package (DigitalReport p b) = nonSysEx (REPORT_DIGITAL_PORT p) [if b then 1 else 0] +package (SetPinMode p m) = nonSysEx SET_PIN_MODE [fromIntegral (pinNo p), fromIntegral (fromEnum m)] +package (DigitalPortWrite p l m) = nonSysEx (DIGITAL_MESSAGE p) [l, m] --- | Unpackage a series of bytes as received from the board into a Response -unpackage :: B.ByteString -> Response -unpackage inp - | length bs < 2 || head bs /= cdStart || last bs /= cdEnd - = Unknown bs +-- | Unpackage a SysEx response +unpackageSysEx :: [Word8] -> Response +unpackageSysEx [] = Unimplemented (Just "") [] +unpackageSysEx (cmdWord:args) + | Right cmd <- getSysExCommand cmdWord + = case (cmd, args) of + (REPORT_FIRMWARE, majV : minV : rest) -> Firmware majV minV (getString rest) + (CAPABILITY_RESPONSE, bs) -> Capabilities (getCapabilities bs) + (ANALOG_MAPPING_RESPONSE, bs) -> AnalogMapping bs + _ -> Unimplemented (Just (show cmd)) args | True - = getResponse (init (tail bs)) - where bs = B.unpack inp + = Unimplemented Nothing (cmdWord : args) --- | Parse a response message. TBD: Use a proper (cereal based?) parser. -getResponse :: [Word8] -> Response -getResponse (rf : majV : minV : rest) - | rf == 0x79 - = Firmware majV minV (getString rest) -getResponse (pr : curPin : pinMode : pinState : []) - | pr == 0x6e - = DigitalPinState (pin (fromIntegral curPin)) (toEnum (fromIntegral pinMode)) (pinState /= 0) -getResponse (dpr : vL : vH : []) - | dpr .&. 0xF0 == 0x90 - = let port = fromIntegral (dpr .&. 0x0F) - w = fromIntegral ((vH .&. 0x7F) `shiftL` 8) .|. fromIntegral (vL .&. 0x7F) - in DigitalPortState port w -getResponse bs = Unknown bs +getCapabilities :: [Word8] -> BoardCapabilities +getCapabilities bs = BoardCapabilities $ M.fromList $ zipWith (\p c -> (p, (Nothing, c))) (map pin [0..]) (map pinCaps (chunk bs)) + where chunk xs = case break (== 0x7f) xs of + ([], []) -> [] + (cur, 0x7f:rest) -> cur : chunk rest + _ -> [xs] + pinCaps (x:y:rest) = (toEnum (fromIntegral x), y) : pinCaps rest + pinCaps _ = [] --- | Turn a lo/hi encoded Arduino string constant into a Haskell string -getString :: [Word8] -> String -getString [] = "" -getString [a] = [chr (fromIntegral a)] -- shouldn't happen, but no need to error out either -getString (l:h:rest) = c : getString rest - where c = chr $ fromIntegral $ h `shiftL` 8 .|. l +-- | Unpackage a Non-SysEx response +unpackageNonSysEx :: (Int -> IO [Word8]) -> FirmataCmd -> IO Response +unpackageNonSysEx getBytes c = grab c + where unimplemented n = Unimplemented (Just (show c)) `fmap` getBytes n + grab (ANALOG_MESSAGE _pin) = unimplemented 2 + grab (DIGITAL_MESSAGE p) = getBytes 2 >>= \[l, h] -> return (DigitalMessage p l h) + grab (REPORT_ANALOG_PIN _pin) = unimplemented 1 + grab (REPORT_DIGITAL_PORT _port) = unimplemented 1 + grab START_SYSEX = unimplemented 0 -- we should never see this + grab SET_PIN_MODE = unimplemented 2 + grab END_SYSEX = unimplemented 0 -- we should never see this + grab PROTOCOL_VERSION = unimplemented 2 + grab SYSTEM_RESET = unimplemented 0 diff --git a/System/Hardware/Arduino/Utils.hs b/System/Hardware/Arduino/Utils.hs --- a/System/Hardware/Arduino/Utils.hs +++ b/System/Hardware/Arduino/Utils.hs @@ -12,8 +12,10 @@ import Control.Concurrent (threadDelay) import Control.Monad (void) +import Data.Bits ((.|.), shiftL) import Data.Char (isAlphaNum, isAscii, isSpace, chr) import Data.IORef (newIORef, readIORef, writeIORef) +import Data.List (intercalate) import Data.Word (Word8) import System.Process (system) import System.Info (os) @@ -47,6 +49,21 @@ where c = chr $ fromIntegral i isVisible = isAscii c && isAlphaNum c && isSpace c +-- | Show a list of bytes +showByteList :: [Word8] -> String +showByteList bs = "[" ++ intercalate ", " (map showByte bs) ++ "]" + -- | Show a number as a binary value showBin :: (Integral a, Show a) => a -> String showBin n = showIntAtBase 2 (head . show) n "" + +-- | Turn a lo/hi encoded Arduino string constant into a Haskell string +getString :: [Word8] -> String +getString [] = "" +getString [a] = [chr (fromIntegral a)] -- shouldn't happen, but no need to error out either +getString (l:h:rest) = c : getString rest + where c = chr $ fromIntegral $ h `shiftL` 8 .|. l + +-- | Error out +die :: String -> [String] -> a +die m ms = error $ "\n*** hArduino:ERROR: " ++ intercalate "\n*** " (m:ms) diff --git a/hArduino.cabal b/hArduino.cabal --- a/hArduino.cabal +++ b/hArduino.cabal @@ -1,5 +1,5 @@ Name: hArduino -Version: 0.1 +Version: 0.2 Category: Hardware Synopsis: Control your Arduino board from Haskell. Description: Control Arduino from Haskell, using the Firmata protocol. @@ -31,15 +31,17 @@ Library default-language: Haskell2010 ghc-options : -Wall --- NB. process is only needed for "sleep", since --- threaddelay is broken on Mac. See: http://hackage.haskell.org/trac/ghc/ticket/7299 - Build-depends : base >= 4 && < 5, serialport, bytestring, mtl, process + Build-depends : base >= 4 && < 5, serialport, bytestring + , mtl , unix, containers + -- NB. process is only needed for "sleep", since + -- threaddelay is broken on Mac. See: http://hackage.haskell.org/trac/ghc/ticket/7299 + , process Exposed-modules : System.Hardware.Arduino , System.Hardware.Arduino.Examples.Blink + , System.Hardware.Arduino.Examples.Switch Other-modules : System.Hardware.Arduino.Comm , System.Hardware.Arduino.Data , System.Hardware.Arduino.Firmata , System.Hardware.Arduino.Firmata.Basics , System.Hardware.Arduino.Protocol - , System.Hardware.Arduino.Parts , System.Hardware.Arduino.Utils