------------------------------------------------------------------------------- -- | -- Module : System.Hardware.Arduino.Firmata -- Copyright : (c) Levent Erkok -- License : BSD3 -- Maintainer : erkokl@gmail.com -- Stability : experimental -- -- Implementation of the firmata protocol ------------------------------------------------------------------------------- {-# LANGUAGE NamedFieldPuns #-} 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