NXT 0.1.8 → 0.2.0
raw patch · 15 files changed
+447/−158 lines, 15 filesdep +HUnitdep +QuickCheckdep +serialportdep ~NXTdep ~basedep ~bytestringnew-component:exe:nxt-status
Dependencies added: HUnit, QuickCheck, serialport, test-framework, test-framework-hunit, test-framework-quickcheck2
Dependency ranges changed: NXT, base, bytestring, filepath, time
Files
- NXT.cabal +112/−79
- ffi/blue.c +0/−12
- ffi/blue.h +0/−1
- ffi/initserial.c +0/−29
- ffi/initserial.h +0/−6
- lib/Robotics/NXT/BluetoothUtils.hs +15/−5
- lib/Robotics/NXT/Externals.hs +8/−0
- lib/Robotics/NXT/Internals.hs +2/−2
- lib/Robotics/NXT/Protocol.hs +15/−21
- lib/Robotics/NXT/Sensor/Ultrasonic.hs +1/−1
- src/Shutdown.hs +1/−1
- src/Status.hs +64/−0
- src/UploadFiles.hs +2/−1
- tests/Main.hs +67/−0
- tests/Robotics/NXT/Basic.hs +160/−0
NXT.cabal view
@@ -1,79 +1,112 @@-Name: NXT-Version: 0.1.8-Synopsis: A Haskell interface to Lego Mindstorms NXT-Description: A Haskell interface to Lego Mindstorms NXT over Bluetoooth. It supports direct commands, messages and- many sensors (also unofficial). It has also support for a simple message-based control of a NXT brick- via remotely executed program (basic NXC code included).- .- It contains two simple programs: @nxt-upload@ for uploading files to a NXT brick and @nxt-shutdown@ for- remote shutdown of a NXT brick.- .- It works best on Linux and it also works on Mac OS X.- .- Feel free to contribute additional features, interfaces for more sensors and propose or write other- (example) programs.-License: LGPL-3-License-file: LICENSE-Author: Mitar Milutinovic-Maintainer: mitar.haskell@tnode.com-Copyright: (c) 2010 Mitar Milutinovic-Category: Robotics-Build-type: Simple-Cabal-version: >= 1.8-Stability: experimental-Homepage: http://mitar.tnode.com-Extra-source-files: remote/remote.rxe,- remote/remote.nxc,- ffi/blue.h,- ffi/initserial.h--Library- Exposed-modules: Robotics.NXT,- Robotics.NXT.MotorControl,- Robotics.NXT.Remote,- Robotics.NXT.Sensor.Compass,- Robotics.NXT.Sensor.Ultrasonic- Build-depends: base >= 4.3 && < 5,- mtl >= 1.1 && < 3,- bytestring >= 0.9 && < 1,- unix >= 2.4 && < 3,- time >= 1.1 && < 2- Other-modules: Robotics.NXT.BluetoothUtils,- Robotics.NXT.Data,- Robotics.NXT.Errors,- Robotics.NXT.Protocol,- Robotics.NXT.Types,- Robotics.NXT.Internals,- Robotics.NXT.Externals- HS-source-dirs: lib- C-sources: ffi/blue.c,- ffi/initserial.c- Includes: ffi/blue.h,- ffi/initserial.h- GHC-options: -Wall- GHC-prof-options: -Wall- GHC-shared-options: -Wall- if os(linux)- Extra-libraries: bluetooth--Source-repository head- type: mercurial- location: https://bitbucket.org/mitar/nxt--Executable nxt-shutdown- Main-is: Shutdown.hs- HS-source-dirs: src- Build-depends: base >= 4.3 && < 5,- mtl >= 1.1 && < 3,- NXT == 0.1.8- GHC-options: -Wall--Executable nxt-upload- Main-is: UploadFiles.hs- HS-source-dirs: src- Build-depends: base >= 4.3 && < 5,- mtl >= 1.1 && < 3,- bytestring >= 0.9 && < 1,- filepath >= 1.1 && < 2,- NXT == 0.1.8- GHC-options: -Wall+Name: NXT +Version: 0.2.0 +Synopsis: A Haskell interface to Lego Mindstorms NXT +Description: A Haskell interface to Lego Mindstorms NXT over Bluetoooth. It supports direct commands, messages and + many sensors (also unofficial). It has also support for a simple message-based control of a NXT brick + via remotely executed program (basic NXC code included). + . + It contains two simple programs: @nxt-upload@ for uploading files to a NXT brick and @nxt-shutdown@ for + remote shutdown of a NXT brick. + . + It works on Linux, Mac OS X and Windows. + . + Feel free to contribute additional features, interfaces for more sensors and propose or write other + (example) programs. +License: LGPL-3 +License-file: LICENSE +Author: Mitar Milutinovic +Maintainer: mitar.haskell@tnode.com +Copyright: (c) 2011 Mitar Milutinovic +Category: Robotics +Build-type: Simple +Cabal-version: >= 1.10 +Stability: experimental +Homepage: http://mitar.tnode.com +Extra-source-files: remote/remote.rxe, + remote/remote.nxc, + ffi/blue.h + +Library + Exposed-modules: Robotics.NXT, + Robotics.NXT.MotorControl, + Robotics.NXT.Remote, + Robotics.NXT.Sensor.Compass, + Robotics.NXT.Sensor.Ultrasonic + Build-depends: base >= 4.3 && < 5, + mtl >= 1.1 && < 3, + bytestring >= 0.9 && < 1, + time >= 1.1 && < 2, + serialport >= 0.4.3 && < 1 + Other-modules: Robotics.NXT.Data, + Robotics.NXT.Errors, + Robotics.NXT.Protocol, + Robotics.NXT.Types, + Robotics.NXT.Internals, + Robotics.NXT.Externals, + Robotics.NXT.BluetoothUtils + HS-source-dirs: lib + GHC-options: -Wall + GHC-prof-options: -Wall + GHC-shared-options: -Wall + Default-language: Haskell2010 + + if !os(windows) + Build-depends: unix >= 2.4 && < 3 + + if os(linux) + C-sources: ffi/blue.c + Includes: ffi/blue.h + Extra-libraries: bluetooth + +Source-repository head + type: mercurial + location: https://bitbucket.org/mitar/nxt + +Executable nxt-shutdown + Main-is: Shutdown.hs + HS-source-dirs: src + Build-depends: base >= 4.3 && < 5, + mtl >= 1.1 && < 3, + NXT == 0.2.0 + GHC-options: -Wall + Default-language: Haskell2010 + +Executable nxt-status + Main-is: Status.hs + HS-source-dirs: src + Build-depends: base >= 4.3 && < 5, + mtl >= 1.1 && < 3, + NXT == 0.2.0 + GHC-options: -Wall + Default-language: Haskell2010 + +Executable nxt-upload + Main-is: UploadFiles.hs + HS-source-dirs: src + Build-depends: base >= 4.3 && < 5, + mtl >= 1.1 && < 3, + bytestring >= 0.9 && < 1, + filepath >= 1.1 && < 2, + NXT == 0.2.0 + GHC-options: -Wall + Default-language: Haskell2010 + +Test-suite nxt-tests + Type: exitcode-stdio-1.0 + X-uses-tf: true + Build-depends: base >= 4, + HUnit >= 1.2 && < 2, + QuickCheck >= 2.4 && < 3, + test-framework >= 0.4 && < 1, + test-framework-quickcheck2 >= 0.2 && < 1, + test-framework-hunit >= 0.2 && < 1, + mtl >= 1.1 && < 3, + time >= 1.2 && < 2, + bytestring >= 0.9 && < 1.0, + filepath >= 1.2 && < 2, + NXT == 0.2.0 + GHC-options: -Wall -rtsopts + Default-language: Haskell2010 + HS-source-dirs: tests + Main-is: Main.hs + Other-modules: Robotics.NXT.Basic
ffi/blue.c view
@@ -6,18 +6,15 @@ // TODO: This works currently only on Linux -#if defined(LINUX) || defined(__linux__) #include <bluetooth/bluetooth.h> #include <bluetooth/hci.h> #include <bluetooth/hci_lib.h>-#endif #include "blue.h" // This is not really thread-safe bool error; -#if defined(LINUX) || defined(__linux__) int findConn(int s, int dev_id, long arg) { struct hci_conn_list_req *cl; struct hci_conn_info *ci;@@ -49,10 +46,8 @@ free(cl); return 0; }-#endif int rssi(char *address) {-#if defined(LINUX) || defined(__linux__) struct hci_conn_info_req *cr; int8_t rssi; int dd, dev_id;@@ -103,13 +98,9 @@ hci_close_dev(dd); return rssi;-#else- return BLUE_NOT_SUPPORTED;-#endif } int lq(char *address) {-#if defined(LINUX) || defined(__linux__) struct hci_conn_info_req *cr; uint8_t lq; int dd, dev_id;@@ -159,7 +150,4 @@ hci_close_dev(dd); return lq;-#else- return BLUE_NOT_SUPPORTED;-#endif }
ffi/blue.h view
@@ -3,7 +3,6 @@ #define BLUE_ERROR 1000 #define BLUE_NOT_CONNECTED 1001-#define BLUE_NOT_SUPPORTED 1002 int rssi(char *address); int lq(char *address);
− ffi/initserial.c
@@ -1,29 +0,0 @@-#include <termios.h>-#include <unistd.h>--#include "initserial.h"--// A simple function which initializes serial port device: 8 bit data, one stop bit, RTS/CTS flow control--int initSerialPort(int fd) {- struct termios params;- - tcflush(fd, TCIOFLUSH);- - if (tcgetattr(fd, ¶ms) == -1) return -1;- - cfmakeraw(¶ms);-#ifdef __MAX_BAUD- cfsetspeed(¶ms, __MAX_BAUD);-#elif defined B230400- cfsetspeed(¶ms, B230400);-#endif- params.c_cflag = CLOCAL | CREAD | CS8 | HUPCL | CRTSCTS;- - //params.c_cc[VTIME] = (5000 + 50) / 100;- //params.c_cc[VMIN] = 0;- - if (tcsetattr(fd, TCSANOW, ¶ms) == -1) return -1;- - return 0;-}
− ffi/initserial.h
@@ -1,6 +0,0 @@-#ifndef INITSERIAL_H_-#define INITSERIAL_H_--int initSerialPort(int fd);--#endif /* INITSERIAL_H_ */
lib/Robotics/NXT/BluetoothUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, CPP #-} {-# CFILES ffi/blue.c #-} module Robotics.NXT.BluetoothUtils (@@ -11,14 +11,17 @@ import Control.Exception import Control.Monad.State+#ifdef linux_HOST_OS import Foreign.C.String import Foreign.C.Types+#endif import Robotics.NXT.Errors import Robotics.NXT.Protocol import Robotics.NXT.Types import Robotics.NXT.Internals +#ifdef linux_HOST_OS -- Foreign function call for C function which returns RSSI Bluetooth value of a connection to a given Bluetooth address foreign import ccall unsafe "rssi" rssi :: CString -> IO CInt @@ -30,8 +33,7 @@ blueError = 1000 blueNotConnected :: Int blueNotConnected = 1001-blueNotSupported :: Int-blueNotSupported = 1002+#endif {-| Gets received signal strength indicator (RSSI) of the Bluetooth connection to the NXT brick.@@ -44,14 +46,18 @@ bluetoothRSSIAddr addr bluetoothRSSIAddr :: BTAddress -> NXT Int+#ifdef linux_HOST_OS bluetoothRSSIAddr addr = do ret <- liftIO $ withCString addr rssi let ret' = fromIntegral ret case ret' of _ | ret' == blueError -> liftIO $ throwIO $ NXTException "Could not get connection's RSSI" | ret' == blueNotConnected -> liftIO $ throwIO $ NXTException "Connection not established"- | ret' == blueNotSupported -> liftIO $ throwIO $ NXTException "Not supported on this system" | otherwise -> return ret'+#else+bluetoothRSSIAddr _ = do+ liftIO $ throwIO $ NXTException "Not supported on this system"+#endif {-| Gets link quality of the Bluetooth connection to the NXT brick.@@ -64,14 +70,18 @@ bluetoothLinkQualityAddr addr bluetoothLinkQualityAddr :: BTAddress -> NXT Int+#ifdef linux_HOST_OS bluetoothLinkQualityAddr addr = do ret <- liftIO $ withCString addr lq let ret' = fromIntegral ret case ret' of _ | ret' == blueError -> liftIO $ throwIO $ NXTException "Could not get connection's link quality" | ret' == blueNotConnected -> liftIO $ throwIO $ NXTException "Connection not established"- | ret' == blueNotSupported -> liftIO $ throwIO $ NXTException "Not supported on this system" | otherwise -> return ret'+#else+bluetoothLinkQualityAddr _ = do+ liftIO $ throwIO $ NXTException "Not supported on this system"+#endif bluetoothAddress :: NXT BTAddress bluetoothAddress = do
lib/Robotics/NXT/Externals.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Robotics.NXT.Externals where +import Control.Exception import Data.Int import Data.Ratio import Data.Time.Clock+import Data.Typeable import Data.Word -- Described in Lego Mindstorms NXT Bluetooth Developer Kit:@@ -171,3 +175,7 @@ type IOMapOffset = Int -- unsigned word type IOMapLength = Int -- unsigned word type IOMapData = [Word8]++-- | Timeout exception for NXT IO operations.+data TimeoutException = TimoutException deriving (Show, Typeable)+instance Exception TimeoutException
lib/Robotics/NXT/Internals.hs view
@@ -5,7 +5,7 @@ import Control.Monad.State import Data.Time.Clock.POSIX import Data.Typeable-import System.IO+import System.Hardware.Serialport import Robotics.NXT.Externals @@ -18,7 +18,7 @@ A token used for exposed internal functions. -} data NXTInternals = NXTInternals {- nxthandle :: Handle, -- a handle of the opened serial port+ nxthandle :: SerialPort, -- a handle of the opened serial port address :: Maybe BTAddress, modules :: [(ModuleName, ModuleInfo)], -- modules info sleeptime :: Maybe Duration, -- sleep time limit in seconds
lib/Robotics/NXT/Protocol.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# CFILES ffi/initserial.c #-}+{-# LANGUAGE CPP #-} module Robotics.NXT.Protocol ( -- * Initialization@@ -112,12 +111,11 @@ import Data.Ratio import Data.Time.Clock.POSIX import Data.Word-import Foreign.C.Error-import Foreign.C.Types import System.IO-import System.Posix.IO+import qualified System.Hardware.Serialport as S+#if (!defined(mingw32_HOST_OS) && !defined(windows_HOST_OS)) import System.Posix.Signals-import System.Posix.Types+#endif import Text.Printf import Robotics.NXT.Data@@ -133,12 +131,6 @@ -- TODO: Add an optional warning if direction of communication changes -- TODO: Implement all missing "confirm" versions of functions --- Foreign function call for C function which initialize serial port device on POSIX systems-foreign import ccall unsafe "initSerialPort" initSerialPort' :: Fd -> IO CInt--initSerialPort :: Fd -> IO ()-initSerialPort fd = throwErrnoIfMinus1_ "initSerialPort" $ initSerialPort' fd- {-| Default Bluetooth serial device filename for current operating system. Currently always @\/dev\/rfcomm0@. -}@@ -153,14 +145,15 @@ -} initialize :: FilePath -> IO NXTInternals initialize device = do+#if (!defined(mingw32_HOST_OS) && !defined(windows_HOST_OS)) -- we have to block signals from interrupting openFd system call (fixed in GHC versions after 6.12.1) let signals = foldl (flip addSignal) emptySignalSet [virtualTimerExpired] blockSignals signals- fd <- openFd device ReadWrite Nothing OpenFileFlags { append = False, noctty = True, exclusive = False, nonBlock = True, trunc = False }+#endif+ h <- S.openSerial device S.defaultSerialSettings { S.commSpeed = S.CS115200, S.timeout = 1000 }+#if (!defined(mingw32_HOST_OS) && !defined(windows_HOST_OS)) unblockSignals signals- initSerialPort fd- h <- fdToHandle fd- hSetBuffering h NoBuffering+#endif when debug $ hPutStrLn stderr "initialized" return $ NXTInternals h Nothing [] Nothing Nothing @@ -172,7 +165,7 @@ terminate i = do i' <- execNXT stopEverything i let h = nxthandle i'- hClose h+ S.closeSerial h when debug $ hPutStrLn stderr "terminated" {-|@@ -193,16 +186,17 @@ h <- getsNXT nxthandle let len = toUWord . length $ message packet = len ++ message- liftIO . B.hPut h . B.pack $ packet+ n <- liftIO . S.send h . B.pack $ packet+ when (n /= length packet) $ liftIO $ failNXT' "not all data has been send" when debug $ liftIO . hPutStrLn stderr $ "sent: " ++ show packet -- Main function for receiving data from NXT receiveData :: NXT [Word8] receiveData = do h <- getsNXT nxthandle- len <- liftIO $ B.hGet h 2+ len <- liftIO $ S.recv h 2 let len' = fromUWord . B.unpack $ len- packet <- liftIO $ B.hGet h len'+ packet <- liftIO $ S.recv h len' let unpacket = B.unpack packet when debug $ liftIO . hPutStrLn stderr $ "received: " ++ show unpacket return unpacket@@ -676,7 +670,7 @@ when debug $ liftIO . hPutStrLn stderr $ "keepalive" current <- liftIO getPOSIXTime modifyNXT (\s -> s { lastkeepalive = Just current })- let send = [0x00, 0x0D]+ let send = [request confirm, 0x0D] sendData send if confirm then do
lib/Robotics/NXT/Sensor/Ultrasonic.hs view
@@ -116,7 +116,7 @@ usGetVendorID input = usReadString input 0x08 8 {-|-Reads vendor ID string (@Sonar@).+Reads device ID string (@Sonar@). -} usGetDeviceID :: InputPort -> NXT String usGetDeviceID input = usReadString input 0x10 8
src/Shutdown.hs view
@@ -41,7 +41,7 @@ exitWith $ ExitFailure 1 when (Help `elem` opts) $ do- putStrLn "Remotely shutdowns a NXT brick.\n"+ putStrLn "Remotely shutdowns the NXT brick.\n" putStrLn usage exitWith ExitSuccess
+ src/Status.hs view
@@ -0,0 +1,64 @@+module Main (+ main+) where++import Control.Monad.State+import Data.Maybe+import Data.List+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import Text.Printf++import Robotics.NXT++data Option = Help | Device FilePath deriving (Eq, Show)++isDevice :: Option -> Bool+isDevice (Device _) = True+isDevice _ = False++options :: [OptDescr Option]+options = [+ Option "h" ["help"] (NoArg Help) "show this help",+ Option "d" ["device"] (ReqArg Device "filename") "serial port device"+ ]++main :: IO ()+main = do+ programName <- getProgName+ let header = programName ++ " [option ...]" ++ "\n\nOptions:"+ usage = "Usage:\n" ++ usageInfo header options+ + args <- getArgs+ opts <- case getOpt Permute options args of+ (o, [], []) -> return o+ (_, _, []) -> do+ hPutStrLn stderr $ "Error(s):\n" ++ "excess argument(s)\n\n" ++ usage+ exitWith $ ExitFailure 1+ (_, _, errs) -> do+ hPutStrLn stderr $ "Error(s):\n" ++ concat errs ++ "\n" ++ usage+ exitWith $ ExitFailure 1+ + when (Help `elem` opts) $ do+ putStrLn "Prints status of the NXT brick.\n"+ putStrLn usage+ exitWith ExitSuccess+ + let Device device = fromMaybe (Device defaultDevice) . find isDevice $ opts+ + withNXT device $ do+ DeviceInfo name btaddress btstrength flashfree <- getDeviceInfo+ Version (FirmwareVersion fmajor fminor) (ProtocolVersion pmajor pminor) <- getVersion+ battery <- getBatteryLevel+ rechargeable <- isBatteryRechargeable+ sleeplimit <- getSleepTimeout+ let fversion = printf "%d.%02d" fmajor fminor :: String+ pversion = printf "%d.%02d" pmajor pminor :: String+ liftIO $ hPutStrLn stderr $ printf "Connected to %s at %s." name btaddress+ liftIO $ hPutStrLn stderr $ printf "Running firmware version %s with protocol version %s." fversion pversion+ liftIO $ hPutStrLn stderr $ printf "Battery level: %f V (%s)" (realToFrac battery :: Double) (if rechargeable then "rechargeable" else "not rechargeable")+ liftIO $ hPutStrLn stderr $ printf "Free space: %d bytes" flashfree+ liftIO $ hPutStrLn stderr $ printf "Signal strength: %d" btstrength+ liftIO $ hPutStrLn stderr $ printf "Sleep time limit: %f s" (realToFrac sleeplimit :: Double)
src/UploadFiles.hs view
@@ -41,7 +41,7 @@ exitWith $ ExitFailure 1 when (Help `elem` opts) $ do- putStrLn "Uploads files to a NXT brick.\n"+ putStrLn "Uploads files to the NXT brick.\n" putStrLn usage exitWith ExitSuccess @@ -67,6 +67,7 @@ h' <- openWrite filename (fromIntegral size) mapM_ (write h') $ chunk 61 content close h'+ liftIO $ putStrLn "Done." chunk _ [] = [[]] chunk n xs = y1 : chunk n y2 where (y1, y2) = splitAt n xs
+ tests/Main.hs view
@@ -0,0 +1,67 @@+module Main where++import Control.Exception+import Control.Monad+import Data.Maybe+import Data.List+import Data.IORef+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++import Test.Framework+import Test.Framework.Providers.HUnit++import Robotics.NXT+import Robotics.NXT.Basic++data Option = Help | Device FilePath deriving (Eq, Show)++isDevice :: Option -> Bool+isDevice (Device _) = True+isDevice _ = False++options :: [OptDescr Option]+options = [+ Option "h" ["help"] (NoArg Help) "show this help",+ Option "d" ["device"] (ReqArg Device "filename") "serial port device"+ ]++main :: IO ()+main = do+ programName <- getProgName+ let header = programName ++ " [option ...]" ++ "\n\nOptions:"+ usage = "Usage:\n" ++ usageInfo header options++ args <- getArgs+ (opts, otherArgs) <- case getOpt Permute options args of+ (o, otherArgs, []) -> return (o, otherArgs)+ (_, _, errs) -> do+ hPutStrLn stderr $ "Error(s):\n" ++ concat errs ++ "\n" ++ usage+ exitWith $ ExitFailure 1++ when (Help `elem` opts) $ do+ putStrLn "Runs the NXT package tests.\n"++ putStrLn usage+ exitWith ExitSuccess++ let Device device = fromMaybe (Device defaultDevice) . find isDevice $ opts++ putStrLn "Please connect a motor to port A, a switch sensor to port 1, an ultrasonic sensor to port 2, and press enter key to continue."++ _ <- try getLine :: IO (Either IOException String)++ bracket+ (initialize device >>= newIORef)+ (\ref -> do+ nxt <- readIORef ref+ terminate nxt+ )+ (\ref -> defaultMainWithArgs (tests ref) otherArgs)+ +tests :: IORef NXTInternals -> [Test]+tests ref = [+ testGroup "Basic Tests" (concatMap hUnitTestToTests (basicTests ref))+ ]
+ tests/Robotics/NXT/Basic.hs view
@@ -0,0 +1,160 @@+module Robotics.NXT.Basic where++import Control.Applicative+import Control.Monad.State hiding (state, runState)+import qualified Data.ByteString.Lazy as B+import Data.IORef+import Data.Maybe+import Data.Time.Clock.POSIX+import System.FilePath+import System.IO+import Test.HUnit++import Robotics.NXT+import Robotics.NXT.Remote+import Robotics.NXT.Sensor.Ultrasonic++basicTests :: IORef NXTInternals -> [Test]+basicTests ref = map (\x -> x ref) [+ testDeviceInfo,+ testProgramUpload,+ testDeviceInit,+ testOutputState,+ testInputMode,+ testUltrasonicSensor+ ]++keepAliveAfter :: Int+keepAliveAfter = 4 * 60 -- 4 minutes (in seconds)++-- Maybe sends a keep alive packet - if more than keepAliveAfter seconds passed from a previous one+maybeKeepAlive :: NXT ()+maybeKeepAlive = do+ lka <- getLastKeepAliveTime+ let lka' = fromMaybe 0 lka+ current <- liftIO getPOSIXTime+ if current - lka' > fromIntegral keepAliveAfter+ then keepAlive+ else return () -- it is not yet time to send a keep alive packet++testNXT :: IORef NXTInternals -> NXT a -> IO a+testNXT ref t = do+ let t' = do r <- t+ maybeKeepAlive+ return r+ nxt <- readIORef ref+ (res, nxt') <- runNXT t' nxt+ writeIORef ref nxt'+ return res++testDeviceInfo :: IORef NXTInternals -> Test+testDeviceInfo ref = TestLabel "testDeviceInfo" $ TestCase $ do+ (DeviceInfo name address _ _) <- testNXT ref getDeviceInfo+ assertBool "name" (not . null $ name)+ putStrLn $ "NXT Name: " ++ name+ assertBool "address" (not . null $ address)+ putStrLn $ "NXT Address: " ++ address++remoteProgramFilename :: String+remoteProgramFilename = "remote/remote.nxc"++testProgramUpload :: IORef NXTInternals -> Test+testProgramUpload ref = TestLabel "testProgramUpload" $ TestCase $ do+ testNXT ref $ do+ stopProgramConfirm+ h <- liftIO $ openBinaryFile remoteProgramFilename ReadMode+ size <- liftIO $ hFileSize h+ content <- liftIO $ B.unpack <$> B.hGetContents h+ let filename = takeFileName remoteProgramFilename+ deleteConfirm filename+ h' <- openWrite filename (fromIntegral size)+ mapM_ (write h') $ chunk 61 content+ close h'+ where chunk _ [] = [[]]+ chunk n xs = y1 : chunk n y2+ where (y1, y2) = splitAt n xs++testDeviceInit :: IORef NXTInternals -> Test+testDeviceInit ref = TestLabel "testDeviceInit" $ TestCase $ do+ testNXT ref $ do+ startRemoteProgram+ mapM_ resetInputScaledValue [One ..]+ mapM_ (`resetMotorPosition` AbsolutePosition) [A ..]+ mapM_ (`resetMotorPosition` RelativePosition) [A ..]+ mapM_ (`resetMotorPosition` InternalPosition) [A ..]+ setOutputStateConfirm A 0 [MotorOn, Brake] RegulationModeIdle 0 MotorRunStateRunning 0+ setOutputStateConfirm B 0 [MotorOn, Brake] RegulationModeIdle 0 MotorRunStateRunning 0+ setOutputStateConfirm C 0 [MotorOn, Brake] RegulationModeIdle 0 MotorRunStateRunning 0++waitfor :: NXT (Bool, Int) -> NXT Bool+waitfor cond = waitfor' []+ where window = 6+ allowed = 10+ waitfor' prev = do+ (c, r) <- cond+ let prev' = take window $ (abs r):prev+ prev'' = derive $ prev'+ speed = (sum prev'') `div` (length prev'')+ if c+ then return True+ else if length prev' < window+ then waitfor' prev'+ else if speed < allowed -- speed should not fall under allowed threshold+ then return False+ else waitfor' prev'+ where derive xs = zipWith (-) xs (tail xs) -- xs is a reversed list++testOutputState :: IORef NXTInternals -> Test+testOutputState ref = TestLabel "testOutputState" $ TestCase $ do+ testNXT ref $ do+ setOutputStateConfirm A 75 [MotorOn, Brake, Regulated] RegulationModeMotorSpeed 0 MotorRunStateRunning 1000+ successful <- waitfor $ do+ OutputState _ _ _ _ _ state _ _ tachoCount _ <- getOutputState A+ return (state == MotorRunStateIdle, fromIntegral tachoCount)+ setOutputStateConfirm A 0 [MotorOn, Brake] RegulationModeIdle 0 MotorRunStateRunning 0+ liftIO $ assertBool "not successful waitfor" successful+ OutputState outputPort outputPower outputMode regulationMode turnRatio runState tachoLimit tachoCount _ _ <- getOutputState A+ liftIO $ do+ assertEqual "outputPort" A outputPort+ assertEqual "outputPower" 0 outputPower+ assertEqual "outputMode" [MotorOn, Brake] outputMode+ assertEqual "regulationMode" RegulationModeIdle regulationMode+ assertEqual "turnRatio" 0 turnRatio+ assertEqual "runState" MotorRunStateRunning runState+ assertEqual "tachoLimit" 0 tachoLimit+ assertBool ("tachoCount !~ 1000: " ++ show tachoCount) (tachoCount > 700 && tachoCount < 1300)++testInputMode :: IORef NXTInternals -> Test+testInputMode ref = TestLabel "testInputMode" $ TestCase $ do+ InputValue inputPort valid _ sensorType sensorMode _ normalizedADValue scaledValue _ <- testNXT ref $ do+ setInputModeConfirm One Switch BooleanMode+ getInputValues One+ assertEqual "inputPort" One inputPort+ assertBool "not valid" valid+ assertEqual "sensorType" Switch sensorType+ assertEqual "sensorMode" BooleanMode sensorMode+ assertBool ("normalizedADValue not in range [0, 1023]: " ++ show normalizedADValue) (normalizedADValue >= 0 && normalizedADValue <= 1023)+ assertEqual "scaledValue" 0 scaledValue++testUltrasonicSensor :: IORef NXTInternals -> Test+testUltrasonicSensor ref = TestLabel "testUltrasonicSensor" $ TestCase $ do+ measurement <- testNXT ref $ do+ usInit Two+ version <- usGetVersion Two+ liftIO $ assertEqual "version" "V1.0" version+ vendor <- usGetVendorID Two+ liftIO $ assertEqual "vendor" "LEGO" vendor+ device <- usGetDeviceID Two+ liftIO $ assertEqual "device" "Sonar" device+ units <- usGetMeasurementUnits Two+ liftIO $ assertEqual "units" "10E-2m" units+ usSetMode Two ContinuousMeasurement+ mode <- usGetMode Two+ liftIO $ assertEqual "mode" ContinuousMeasurement mode+ usSetMode Two SingleShot+ measurement <- usGetMeasurement Two 0+ usSetMode Two Off+ mode' <- usGetMode Two+ liftIO $ assertEqual "mode" Off mode'+ return measurement+ putStrLn $ "Ultrasonic sensor measurement: " ++ (show measurement)