hArduino-1.2: System/Hardware/Arduino/Firmata.hs
-------------------------------------------------------------------------------
-- |
-- Module : System.Hardware.Arduino.Firmata
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Implementation of the firmata protocol
-------------------------------------------------------------------------------
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module System.Hardware.Arduino.Firmata where
import Control.Concurrent (newEmptyMVar, readMVar, withMVar, modifyMVar_, threadDelay)
import Control.Monad (when, unless, void)
import Control.Monad.State (StateT(..), gets)
import Control.Monad.Trans (liftIO)
import Data.Bits ((.&.), shiftR, setBit)
import Data.Maybe (fromMaybe)
import Data.Time (getCurrentTime, utctDayTime)
import System.Timeout (timeout)
import Data.Word (Word8)
import qualified Data.Map as M
import System.Hardware.Arduino.Data
import System.Hardware.Arduino.Comm
import qualified System.Hardware.Arduino.Utils as U
-- | Retrieve the Firmata firmware version running on the Arduino. The first
-- component is the major, second is the minor. The final value is a human
-- readable identifier for the particular board.
queryFirmware :: Arduino (Word8, Word8, String)
queryFirmware = do
send QueryFirmware
r <- recv
case r of
Firmware v1 v2 m -> return (v1, v2, m)
_ -> die "queryFirmware: Got unexpected response for query firmware call: " [show r]
-- | Delay the computaton for a given number of milli-seconds
delay :: Int -> Arduino ()
delay = liftIO . U.delay
-- | Time a given action, result is measured in micro-seconds.
time :: Arduino a -> Arduino (Int, a)
time a = do start <- tick
r <- a
end <- r `seq` tick
return (toMicroSeconds (end - start), r)
where -- tick gets the current time in picoseconds
tick = do t <- liftIO $ utctDayTime `fmap` getCurrentTime
let precision = 1000000000000 :: Integer
return . round . (fromIntegral precision *) . toRational $ t
toMicroSeconds :: Integer -> Int
toMicroSeconds t = fromIntegral $ t `quot` 1000000
-- | Time-out a given action. Time-out amount is in micro-seconds.
timeOut :: Int -> Arduino a -> Arduino (Maybe a)
timeOut to (Arduino (StateT f)) = Arduino (StateT (\st -> do
mbRes <- timeout to (f st)
case mbRes of
Nothing -> return (Nothing, st)
Just (a, st') -> return (Just a, st')))
-- | Set the mode on a particular pin on the board
setPinMode :: Pin -> PinMode -> Arduino ()
setPinMode p' m = do
p <- getInternalPin p'
extras <- registerPinMode p m
send $ SetPinMode p m
mapM_ send extras
-- | Set or clear a digital pin on the board
digitalWrite :: Pin -> Bool -> Arduino ()
digitalWrite p' v = do
(p, pd) <- convertAndCheckPin "digitalWrite" p' OUTPUT
case pinValue pd of
Just (Left b) | b == v -> return () -- no change, nothing to do
_ -> do (lsb, msb) <- computePortData p v
send $ DigitalPortWrite (pinPort p) lsb msb
-- | Turn on/off internal pull-up resistor on an input pin
pullUpResistor :: Pin -> Bool -> Arduino ()
pullUpResistor p' v = do
(p, _) <- convertAndCheckPin "pullUpResistor" p' INPUT
(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
(_, pd) <- convertAndCheckPin "digitalRead" p' INPUT
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 = head `fmap` waitAny [p]
-- | Wait for a change in any of the given pins. Once a change is detected, all the new values are
-- returned. Similar to 'waitFor', but is useful when we are watching multiple digital inputs.
waitAny :: [Pin] -> Arduino [Bool]
waitAny ps = map snd `fmap` waitGeneric ps
-- | Wait for any of the given pins to go from low to high. If all of the pins are high to start
-- with, then we first wait for one of them to go low, and then wait for one of them to go back high.
-- Returns the new values.
waitAnyHigh :: [Pin] -> Arduino [Bool]
waitAnyHigh ps = do
curVals <- mapM digitalRead ps
when (and curVals) $ void $ waitAnyLow ps -- all are H to start with, wait for at least one to go low
vs <- waitGeneric ps -- wait for some change
if (False, True) `elem` vs
then return $ map snd vs
else waitAnyHigh ps
-- | Wait for any of the given pins to go from high to low. If all of the pins are low to start
-- with, then we first wait for one of them to go high, and then wait for one of them to go back low.
-- Returns the new values.
waitAnyLow :: [Pin] -> Arduino [Bool]
waitAnyLow ps = do
curVals <- mapM digitalRead ps
unless (or curVals) $ void $ waitAnyHigh ps -- all are L to start with, wait for at least one to go high
vs <- waitGeneric ps -- wait for some change
if (True, False) `elem` vs
then return $ map snd vs
else waitAnyLow ps
-- | A utility function, waits for any change on any given pin
-- and returns both old and new values. It's guaranteed that
-- at least one returned pair have differing values.
waitGeneric :: [Pin] -> Arduino [(Bool, Bool)]
waitGeneric ps = do
curVals <- mapM digitalRead ps
semaphore <- liftIO newEmptyMVar
let wait = do digitalWakeUp semaphore
liftIO $ readMVar semaphore
newVals <- mapM digitalRead ps
if curVals == newVals
then wait
else return $ zip curVals newVals
wait
-- | Send down a pulse, and measure how long the pin reports a corresponding pulse, with a potential time-out. The call @pulse p v duration mbTimeOut@
-- does the following:
--
-- * Set the pin to value @v@ for @duration@ microseconds.
--
-- * Waits 2 microseconds
--
-- * Waits until pin @p@ has value @not v@.
--
-- * Returns, in micro-seconds, the duration the pin stayed @v@, counting from the 2 microsecond wait.
--
-- Time-out parameter is used as follows:
--
-- * If @mbTimeOut@ is @Nothing@, then 'pulse' will wait until the pin attains the value required and so long as it holds it.
-- Note that very-long time-out values are unlikely to be accurate.
--
-- * If @mbTimeOut@ is @Just t@ then, 'pulse' will stop if the above procedure does not complete within the given micro-seconds.
-- In this case, the overall return value is @Nothing@.
--
-- NB. Both the time-out value and the return value are given in micro-seconds.
--
-- NB. As of March 2 2013; StandardFirmata that's distributed with the Arduino-App does /not/ support the Pulse-In command.
-- However, there is a patch to add this command; see: <http://github.com/rwldrn/johnny-five/issues/18> for details.
-- If you want to use hArduino's @pulseIn@ command, then you /have/ to install the above patch. Also see the function
-- @pulseIn_hostOnly@, which works with the distributed StandardFirmata: It implements a version that is not as
-- accurate in its timing, but might be sufficient if high precision is not required.
pulse :: Pin -> Bool -> Int -> Maybe Int -> Arduino (Maybe Int)
pulse p' v duration mbTo = do
(p, _) <- convertAndCheckPin "pulse" p' INPUT
let to = fromMaybe maxAllowed mbTo
maxAllowed = 2147483647 -- works out to about 36 minutes; which is way beyond the accuracy provided by Arduino
bad x = x < 0 || x > maxAllowed
when (any bad [duration, to]) $ die ("Invalid duration/time-out values for pulse on pin " ++ show p)
[ "Values should be between 0 and " ++ show maxAllowed
, "Received: " ++ show (duration, to)
]
send $ Pulse p v (fromIntegral duration) (fromIntegral to)
r <- recv
case r of
PulseResponse pOut d | p == pOut -> case d of
0 -> return Nothing
i -> return (Just (fromIntegral i))
_ -> die ("pulseIn: Got unexpected response for Pulse call on pin: " ++ show p') [show r]
-- | A /hostOnly/ version of pulse-out on a digital-pin. Use this function only for cases where the
-- precision required only matters for the host, not for the board. That is, due to the inherent
-- delays involved in Firmata communication, the timing will /not/ be accurate, and should not
-- be expected to work uniformly over different boards. Similar comments apply for 'pulseIn_hostTiming'
-- as well. See the function 'pulse' for a more accurate version.
pulseOut_hostTiming :: Pin -- ^ Pin to send the pulse on
-> Bool -- ^ Pulse value
-> Int -- ^ Time, in microseconds, to signal beginning of pulse; will send the opposite value for this amount
-> Int -- ^ Pulse duration, measured in microseconds
-> Arduino ()
pulseOut_hostTiming p' pulseValue dBefore dAfter
| dBefore < 0 || dAfter < 0
= die ("pulseOut: Invalid delay amounts: " ++ show (dBefore, dAfter))
[ "Pre-delay and pulse-amounts must be non-negative."]
| True
= do (p, pd) <- convertAndCheckPin "pulseOut_hostTiming" p' OUTPUT
let curPort = pinPort p
curIndex = pinPortIndex p
bs <- gets boardState
(setMask, resetMask) <- liftIO $ withMVar bs $ \bst -> do
let values = [(pinPortIndex sp, pinValue spd) | (sp, spd) <- M.assocs (pinStates bst), curPort == pinPort sp, pinMode pd `elem` [INPUT, OUTPUT]]
getVal nv i
| i == curIndex = nv
| Just (Just (Left ov)) <- i `lookup` values = ov
| True = False
mkMask val = let [b0, b1, b2, b3, b4, b5, b6, b7] = map (getVal val) [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])
in (lsb, msb)
return (mkMask pulseValue, mkMask (not pulseValue))
let writeThrough (lsb, msb) = send $ DigitalPortWrite curPort lsb msb
-- make sure masks are pre computed, and clear the line
fst setMask `seq` snd setMask `seq` fst resetMask `seq` snd resetMask `seq` writeThrough resetMask
-- Wait before starting the pulse
liftIO $ threadDelay dBefore
-- Send the pulse
writeThrough setMask
liftIO $ threadDelay dAfter
-- Finish the pulse
writeThrough resetMask
-- Do a final internal update to reflect the final value of the line
liftIO $ modifyMVar_ bs $ \bst -> return bst{pinStates = M.insert p PinData{pinMode = OUTPUT, pinValue = Just (Left (not pulseValue))}(pinStates bst)}
{-# ANN pulseOut_hostTiming "HLint: ignore Use camelCase" #-}
-- | A /hostOnly/ version of pulse-in on a digital-pin. Use this function only for cases where the
-- precision required only matters for the host, not for the board. That is, due to the inherent
-- delays involved in Firmata communication, the timing will /not/ be accurate, and should not
-- be expected to work uniformly over different boards. Similar comments apply for 'pulseOut_hostTiming'
-- as well. See the function 'pulse' for a more accurate version.
pulseIn_hostTiming :: Pin -> Bool -> Maybe Int -> Arduino (Maybe Int)
pulseIn_hostTiming p v mbTo = case mbTo of
Nothing -> Just `fmap` measure
Just to -> timeOut to measure
where waitTill f = do curVal <- digitalRead p
unless (f curVal) $ waitTill f
measure = do waitTill (== v) -- wait until pulse starts
(t, _) <- time $ waitTill (/= v) -- wait till pulse ends, measuring the time
return $ fromIntegral t
{-# ANN pulseIn_hostTiming "HLint: ignore Use camelCase" #-}
-- | Read the value of a pin in analog mode; this is a non-blocking call, immediately
-- returning the last sampled value. It returns @0@ if the voltage on the pin
-- is 0V, and @1023@ if it is 5V, properly scaled. (See `setAnalogSamplingInterval` for
-- sampling frequency.)
analogRead :: Pin -> Arduino Int
analogRead p' = do
(_, pd) <- convertAndCheckPin "analogRead" p' ANALOG
return $ case pinValue pd of
Just (Right v) -> v
_ -> 0 -- no (correctly-typed) value reported yet, default to 0
-- | Write a PWM analog value to a pin. The argument is an 'Int', indicating the duty cycle.
-- @0@ means off; @255@ means always on. Intermediate values will create a square wave
-- on that pin with the given duty-cycle
analogWrite :: Pin -> Int -> Arduino ()
analogWrite p' dc = do
(p, _) <- convertAndCheckPin "analogWrite" p' PWM
when (dc < 0 || dc > 255) $ die ("Invalid duty-cycle value for PWM write on pin " ++ show p)
[ "Values should be between 0 and 255"
, "Received: " ++ show dc
]
send $ AnalogPinWrite p (fromIntegral lsb) (fromIntegral msb)
where lsb = dc .&. 0x7f
msb = (dc `shiftR` 7) .&. 0x7f
-- | Set the analog sampling interval, in milliseconds. Arduino uses a default of 19ms to sample analog and I2C
-- signals, which is fine for many applications, but can be modified if needed. The argument
-- should be a number between @10@ and @16384@; @10@ being the minumum sampling interval supported by Arduino
-- and @16383@ being the largest value we can represent in 14 bits that this message can handle. (Note that
-- the largest value is just about @16@ seconds, which is plenty infrequent for all practical needs.)
setAnalogSamplingInterval :: Int -> Arduino ()
setAnalogSamplingInterval i
| i < 10 || i > 16383
= die ("hArduino: setAnalogSamplingInterval: Allowed interval is [10, 16383] ms, received: " ++ show i) []
| True
= send $ SamplingInterval (fromIntegral lsb) (fromIntegral msb)
where lsb = i .&. 0x7f
msb = (i `shiftR` 7) .&. 0x7f