diff --git a/NXT.cabal b/NXT.cabal --- a/NXT.cabal +++ b/NXT.cabal @@ -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 diff --git a/ffi/blue.c b/ffi/blue.c --- a/ffi/blue.c +++ b/ffi/blue.c @@ -6,18 +6,15 @@ // TODO: This works currently only on Linux -#if defined(LINUX) || defined(__linux__) #include #include #include -#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 } diff --git a/ffi/blue.h b/ffi/blue.h --- a/ffi/blue.h +++ b/ffi/blue.h @@ -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); diff --git a/ffi/initserial.c b/ffi/initserial.c deleted file mode 100644 --- a/ffi/initserial.c +++ /dev/null @@ -1,29 +0,0 @@ -#include -#include - -#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; -} diff --git a/ffi/initserial.h b/ffi/initserial.h deleted file mode 100644 --- a/ffi/initserial.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef INITSERIAL_H_ -#define INITSERIAL_H_ - -int initSerialPort(int fd); - -#endif /* INITSERIAL_H_ */ diff --git a/lib/Robotics/NXT/BluetoothUtils.hs b/lib/Robotics/NXT/BluetoothUtils.hs --- a/lib/Robotics/NXT/BluetoothUtils.hs +++ b/lib/Robotics/NXT/BluetoothUtils.hs @@ -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 diff --git a/lib/Robotics/NXT/Externals.hs b/lib/Robotics/NXT/Externals.hs --- a/lib/Robotics/NXT/Externals.hs +++ b/lib/Robotics/NXT/Externals.hs @@ -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 diff --git a/lib/Robotics/NXT/Internals.hs b/lib/Robotics/NXT/Internals.hs --- a/lib/Robotics/NXT/Internals.hs +++ b/lib/Robotics/NXT/Internals.hs @@ -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 diff --git a/lib/Robotics/NXT/Protocol.hs b/lib/Robotics/NXT/Protocol.hs --- a/lib/Robotics/NXT/Protocol.hs +++ b/lib/Robotics/NXT/Protocol.hs @@ -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 diff --git a/lib/Robotics/NXT/Sensor/Ultrasonic.hs b/lib/Robotics/NXT/Sensor/Ultrasonic.hs --- a/lib/Robotics/NXT/Sensor/Ultrasonic.hs +++ b/lib/Robotics/NXT/Sensor/Ultrasonic.hs @@ -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 diff --git a/src/Shutdown.hs b/src/Shutdown.hs --- a/src/Shutdown.hs +++ b/src/Shutdown.hs @@ -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 diff --git a/src/Status.hs b/src/Status.hs new file mode 100644 --- /dev/null +++ b/src/Status.hs @@ -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) diff --git a/src/UploadFiles.hs b/src/UploadFiles.hs --- a/src/UploadFiles.hs +++ b/src/UploadFiles.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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)) + ] diff --git a/tests/Robotics/NXT/Basic.hs b/tests/Robotics/NXT/Basic.hs new file mode 100644 --- /dev/null +++ b/tests/Robotics/NXT/Basic.hs @@ -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)