monad to encapsulate stop action

nxt-samples.cabal

@@ -13,9 +13,11 @@ license-file:   LICENSE
 copyright:      (c)JP Moresmau 2012
 
 executable bumper
-  build-depends:   base >= 4,
+  build-depends:   
+                   base >= 4,
                    NXT,
-                   transformers
+                   transformers,
+                   mtl
   hs-source-dirs:  src
   ghc-options:     -Wall -rtsopts
   main-is:         Bumper.hs
@@ -24,7 +26,8 @@ executable bumper
 executable gator
   build-depends:   
                    base >= 4,
-                   GLUT
+                   GLUT,
+                   mtl
   hs-source-dirs:  src
   ghc-options:     -Wall -rtsopts
   other-modules:   Robotics.NXT.Samples.Helpers

src/Bumper.hs

@@ -10,10 +10,11 @@ import Robotics.NXT.Samples.Helpers
 import System.Environment (getArgs)
 import Control.Concurrent (threadDelay,forkIO)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad (forever)
 
 import Data.IORef
 import System.IO
+import Control.Monad.State.Lazy (evalStateT)
+import Control.Monad.Trans.Class (lift)
 
 -- | the main method
 main :: IO()
@@ -29,32 +30,28 @@ main = do
                 return () 
                 )
         withNXT device (do
-                reset [B,C]
-                forever $ loop $ pollForStopIOR iorC
-                reset [B,C]
+                evalStateT (do
+                        reset [B,C]
+                        forever loop 
+                        reset [B,C]
+                        ) (pollForStopIOR iorC)
                 liftIO $ threadDelay 1000000  -- wait before killing everything probably not needed after reset   
                 )
         --killThread tid 
 
--- | waits for user to press space, this stops the robot
-waitForStop :: IORef Bool-> IO()
-waitForStop iorC=do
-        c<-getChar
-        if c == ' ' then
-          do atomicModifyIORef iorC (\ a -> (False, a))
-             return ()
-          else waitForStop iorC
+
 
 -- | the main loop for the robot
-loop :: PollForStop -- ^ the stopping action
-        -> NXT()
-loop iorC= do
-  move iorC [B,C] 75 [0,0] 0 -- move forever
-  setInputModeConfirm One Switch BooleanMode -- set the sensor on port One to switch mode
-  pollForScaled iorC One 0 -- wait for sensor to be triggered
+loop :: --PollForStop -- ^ the stopping action
+        -- -> 
+        StopSt()
+loop = do
+  move  [B,C] 75 [0,0] 0 -- move forever
+  lift $ setInputModeConfirm One Switch BooleanMode -- set the sensor on port One to switch mode
+  pollForScaled  One 0 -- wait for sensor to be triggered
   stop [B,C] -- stop
-  move iorC [B,C] (-75) [0,0] 360 -- reverse
-  move iorC [B,C] (-75) [100,-100] 360 -- turn
+  move [B,C] (-75) [0,0] 360 -- reverse
+  move [B,C] (-75) [100,-100] 360 -- turn
   stop [B,C] -- stop
 
 

src/Gator.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
 -- | the alligator moves towards a detected target and bites...
 -- 
 module Main where
@@ -9,27 +10,43 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent
 
 import Robotics.NXT.Sensor.Ultrasonic
+import Control.Monad.State.Lazy (evalStateT)
+import Data.IORef (newIORef)
+import System.IO (hSetBuffering, stdin, stdout, BufferMode(NoBuffering))
 
 main :: IO()
 main = do
         (device:_)<-getArgs
+        iorC<-newIORef True
+        forkIO (do
+                hSetBuffering stdin NoBuffering
+                hSetBuffering stdout NoBuffering -- does not Work on windows
+                putStrLn "press space to stop robot"
+                waitForStop iorC
+                putStrLn "stopping..."
+                return () 
+                )
         withNXT device (do
-                reset [A]
+                let poll=pollForStopIOR iorC
                 usInit Four
-                let poll=pollNeverStop
-                pollForUltrasonic poll Four 60
-                move poll [B,C] (-75) [0,0] 800
-                bite poll A
+                evalStateT (do
+                        reset [A]
+                        forever (do 
+                                pollForUltrasonic Four 60
+                                move [B,C] (-100) [0,0] 800
+                                bite A
+                               )
+                        ) poll
                 usSetMode Four Off
                 )
 
 
-bite :: PollForStop -> OutputPort -> NXT()
-bite poll port=do
-        move poll [port] 75 [0] 10
+bite :: OutputPort -> StopSt ()
+bite port=do
+        move [port] 75 [0] 10
         reset [port]
         liftIO $ threadDelay 20000
-        move poll [port] (-75) [0] 5  
+        move [port] (-75) [0] 5  
         reset [port]
 
 

src/Robotics/NXT/Samples/Helpers.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
 -- | helper method around the NXT library calls
 module Robotics.NXT.Samples.Helpers where
 
@@ -9,65 +10,72 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad (when, unless)
 
 import Data.IORef
+import Control.Monad.State.Lazy (StateT, get)
+import Control.Monad.Trans.Class (lift)
 
 
 type PollForStop= NXT Bool
 
+type StopSt=StateT PollForStop NXT
+
 -- | reset the NXT brick motors
 reset :: [OutputPort] -- ^ the output ports
-        -> NXT()
+        -> StopSt()
 reset = mapM_ resetMotor
 
 
 -- | reset a motor
 resetMotor :: OutputPort -- ^ the output port
-        -> NXT()
-resetMotor p= mapM_ (resetMotorPosition p) [InternalPosition,AbsolutePosition,RelativePosition]
+        -> StopSt()
+resetMotor p= lift $ mapM_ (resetMotorPosition p) [InternalPosition,AbsolutePosition,RelativePosition]
 
 -- | stop the motors on the given port  
-stop :: [OutputPort] -> NXT()
-stop ports=mapM_ (\p->setOutputStateConfirm p 0 [Regulated,Brake] (regulate ports) 0 MotorRunStateIdle 0) ports
+stop :: [OutputPort] -> StopSt()
+stop ports=lift $ mapM_ (\p->setOutputStateConfirm p 0 [Regulated,Brake] (regulate ports) 0 MotorRunStateIdle 0) ports
 
 -- | move motors on the given ports till the limit has been reached or the stop signal sent       
-move :: PollForStop -- ^ the stopping action
-        -> [OutputPort] -- ^ the output port
+move :: --PollForStop -- ^ the stopping action
+        -- -> 
+        [OutputPort] -- ^ the output port
         -> OutputPower  -- ^ the power to apply
         -> [TurnRatio] -- ^ the turn ratio between engine
         -> TachoLimit -- ^ the move limit
-        -> NXT()
-move iorC ports power ratios limit=pollForStop iorC $ do
+        -> StopSt()
+move ports power ratios limit=pollForStop $ do
         let port1= head ports
-        OutputState _ _ _ _ _ _ _ count _ _<-getOutputState port1
-        mapM_ (\(p,r)->setOutputStateConfirm p power [Regulated,MotorOn] (regulate ports) r MotorRunStateRunning limit) $ zip ports ratios
-        when (limit>0) (pollForCount iorC port1 (count+limit))
+        OutputState _ _ _ _ _ _ _ count _ _<-lift $ getOutputState port1
+        mapM_ (\(p,r)->lift $ setOutputStateConfirm p power [Regulated,MotorOn] (regulate ports) r MotorRunStateRunning limit) $ zip ports ratios
+        when (limit>0) (pollForCount port1 (count+limit))
 
 regulate :: [OutputPort] ->  RegulationMode
 regulate [_]=RegulationModeIdle
 regulate [] =RegulationModeIdle
 regulate _ = RegulationModeMotorSync
 
 -- | wait for the given motor to have reached the limit        
-pollForCount :: PollForStop -- ^ the stopping action
-        -> OutputPort -- ^ the output port
+pollForCount :: --PollForStop -- ^ the stopping action
+        -- -> 
+        OutputPort -- ^ the output port
         -> TachoLimit -- ^ the limit
-        -> NXT()
-pollForCount iorC port limit=pollForStop iorC $ do
-        OutputState _ _ _ _ _ state _ count _ _<-getOutputState port
+        -> StopSt()
+pollForCount port limit=pollForStop $ do
+        OutputState _ _ _ _ _ state _ count _ _<-lift $ getOutputState port
         when (state/=MotorRunStateIdle && count<limit) (do
                 liftIO $ threadDelay 500
-                pollForCount iorC port limit
+                pollForCount port limit
                 )       
 
 -- | wait for the input value to reach the given value      
-pollForScaled :: PollForStop -- ^ the stopping action
-         -> InputPort -- ^ the input port 
+pollForScaled :: -- PollForStop -- ^ the stopping action
+         -- -> 
+         InputPort -- ^ the input port 
          -> ScaledValue -- ^ the value to wait for
-         -> NXT()
-pollForScaled iorC port v=pollForStop iorC $ do
-      InputValue _ _ _ _ _ _ _ scalV _<-getInputValues port
+         -> StopSt()
+pollForScaled port v=pollForStop $ do
+      InputValue _ _ _ _ _ _ _ scalV _<-lift $ getInputValues port
       when (scalV==v) ( do
                 liftIO $ threadDelay 500
-                pollForScaled iorC port v
+                pollForScaled port v
                 ) 
 
 pollForStopIOR :: IORef Bool  -- ^ the stop signal ioref
@@ -78,25 +86,44 @@ pollNeverStop :: PollForStop
 pollNeverStop = return True
 
 -- | only perform the given action if the user hasn't said stop                
-pollForStop :: PollForStop -- ^ the stopping action
-        -> NXT() -- ^ the action to perform 
-        -> NXT()
-pollForStop pfs f=do
-        c<-pfs
+pollForStop :: --PollForStop -- ^ the stopping action
+        -- -> 
+        StopSt () -- ^ the action to perform 
+        -> StopSt ()
+pollForStop f=do
+        c<-lift =<< get
         when c f
+
+forever ::   StopSt () -- ^ the action to perform 
+        -> StopSt ()
+forever f=do
+        c<-lift =<< get
+        when c (do
+                f
+                forever f)
 
-pollForUltrasonic :: PollForStop
-                                    -> InputPort
+pollForUltrasonic :: --PollForStop
+                     --               -> 
+                        InputPort
                                     -> Measurement
-                                    -> NXT ()
-pollForUltrasonic iorC port v=pollForStop iorC $ do
-      mM<-usGetMeasurement port 0
+                                    -> StopSt ()
+pollForUltrasonic port v=pollForStop $ do
+      mM<-lift $ usGetMeasurement port 0
       ok<-case mM of
         Just m->do
                 liftIO $ print m
                 return $ m<v
         Nothing->return False
       unless ok ( do
                 liftIO $ threadDelay 50000
-                pollForUltrasonic iorC port v
-                )      
+                pollForUltrasonic port v
+                )     
+
+-- | waits for user to press space, this stops the robot
+waitForStop :: IORef Bool-> IO()
+waitForStop iorC=do
+        c<-getChar
+        if c == ' ' then
+          do atomicModifyIORef iorC (\ a -> (False, a))
+             return ()
+          else waitForStop iorC