#lang racket/base
(require (for-syntax racket/base
syntax/parse)
racket/match
racket/system
(planet neil/mcfly))
(module+ test
(require (planet neil/overeasy:3)))
(doc (require scribble/bnf))
(doc (section "Introduction")
(para "This package implements a "
(hyperlink "http://docs.racket-lang.org/"
"Racket")
" interface for controlling many "
(tech "models")
" of the "
(hyperlink "http://en.wikipedia.org/wiki/Roomba"
"iRobot Roomba")
" robot vacuum cleaner, and the "
(hyperlink "http://www.irobot.com/create"
"iRobot Create")
". This package currently runs on some Unix-like operating systems,
such as GNU/Linux and possibly Apple Mac OS X.")
(para "One reason to control a Roomba using Racket is "
(hyperlink "http://en.wikipedia.org/wiki/Constructionism_%28learning_theory%29"
"constructionist learning")
" opportunities for children. Another reason is various hobby projects,
getting the robot hardware to do useful or amusing things other than clean
one's floor, perhaps as a small piece of something much bigger. Another reason
is the principle among engineer-types that it is good to be able to modify,
experiment with, and improve things that you own.")
(para "Using this package requires first using a special cable or hardware
interface to connect the computer running your Racket program with the
Roomba. "
"(If you don't already have such a cable or hardware interface, you
can sometimes buy them, or you can build one using instructions found on the
Web.) This package implements the protocol that is used over that hardware
connection. You then write your program using the definitions provided by this
package.")
(para "Obligatory Cautions: Roomba hacking is not without risks; don't sue
us. Also, this package is "
(italic "not")
" produced by iRobot Corp.; please don't bother them about this
package.")
)
(doc (section "Logging")
(para "This package sends logging messages to the "
" Racket "
(hyperlink "http://docs.racket-lang.org/reference/logging.html"
"logger")
", naming the messages as ``"
(tt "roomba")
"''. This includes "
(tt "debug")
" level messages for each use of most of this package's API. You
can see these messages in the usual Racket ways, such as by using the "
(tt "PLTSTDERR")
" environment variable, or via the DrRacket Log window."))
(define-logger roomba)
(doc (section "Exceptions"))
(doc (defstruct* (exn:fail:roomba exn:fail)
((roomba roomba?))
(para "Supertype for exceptions related to the Roomba.")))
(provide exn:fail:roomba?
exn:fail:roomba-roomba)
(define-struct (exn:fail:roomba exn:fail)
(roomba)
#:transparent)
(doc (defstruct* (exn:fail:roomba:io exn:fail:roomba)
()
(para "Exception due to I/O problem with communication link with the
Roomba.")))
(provide exn:fail:roomba:mode?)
(define-struct (exn:fail:roomba:io exn:fail:roomba)
()
#:transparent)
(doc (defstruct* (exn:fail:roomba:mode exn:fail:roomba)
((expected (listof symbol?))
(actual symbol?))
(para "Exception due to attempting to use a command on the Roomba when
it is not believed to be in the proper "
(tech "mode")
" for that command.")))
(provide exn:fail:roomba:mode?
exn:fail:roomba:mode-expected
exn:fail:roomba:mode-actual)
(define-struct (exn:fail:roomba:mode exn:fail:roomba)
(expected
actual)
#:transparent)
(doc (section "Protocols")
(para "This package supports a few different Roomba "
(deftech "protocols")
"."))
(define (%roomba-protocol-struct-write-proc roomba port write?)
(fprintf port
"#<roomba-protocol ~S>"
(roomba-protocol-struct-symbol roomba)))
(doc (defproc (roomba-protocol? (any/c x))
boolean?
(para "Predicate for a "
(racket roomba-protocol)
" object.")))
(provide (rename-out (roomba-protocol-struct? roomba-protocol?)))
(define-struct roomba-protocol-struct
(symbol
default-baud
post-start-opcode)
#:methods
gen:custom-write ((define write-proc %roomba-protocol-struct-write-proc)))
(doc (defthing roomba-sci roomba-protocol?
(para "Protocol used by the Roomba second generation, especially the 400
series, described by "
(hyperlink "http://www.usna.edu/Users/weapsys/esposito/roomba.matlab/Roomba_SCI.pdf"
(italic "iRobot Roomba Serial Command Interface (SCI) Specification"))
", dated 2005.")
(para "Note that not all second generation Roombas shipped with firmware
that supports SCI, but reportedly all of them can be upgraded with 2.1
firmware. If the Roomba was not manufactured after October 2005, then search
the Web for ``roomba firmware update'' for your particular model number. The
update process will likely involve an iRobot OSMO dongle, or using the iRobot
Scheduler Remote with a special cable). If you need help determining the model
number or manufacturing date, see section "
(secref "Models")
" of this document.")))
(provide roomba-sci)
(define roomba-sci (make-roomba-protocol-struct 'roomba-sci 57600 130))
(doc (defthing roomba-roi roomba-protocol?
(para "Protocol used by the Roomba 500 and 600 series, described by "
(hyperlink "http://www.irobot.lv/uploaded_files/File/iRobot_Roomba_500_Open_Interface_Spec.pdf"
(italic "iRobot Roomba 500 Open Interface (OI) Specification"))
".")))
(provide roomba-roi)
(define roomba-roi (make-roomba-protocol-struct 'roomba-roi 115200 131))
(doc (defthing roomba-coi roomba-protocol?
(para "Protocol used by the iRobot Create, described by "
(hyperlink "http://www.irobot.com/filelibrary/pdfs/hrd/create/Create%20Open%20Interface_v2.pdf"
(italic "iRobot Create Open Interface (OI) Specification"))
". (We say ``"
(tt "roomba")
"'' even though it's for a Create rather than a Roomba, due to the
identifier naming convention of this package.)")))
(provide roomba-coi)
(define roomba-coi (make-roomba-protocol-struct 'roomba-coi 57600 131))
(doc (section "Models")
(para "A "
(deftech "model")
" refers to a particular manufactured model of Roomba or similar
robot, such as the iRobot Create. This package defines a number of specific
Roomba models, and you can also define your own.")
(para "If you don't know which model of Roomba you have, or you need to
know the manufacturing date, look for the serial number barcode label on the
Roomba or the box. Given a serial number label like, for example, ``"
(tt "JEN 04000 090620 08 00999")
"'', the model number is given by the ``04000'', and the date is
in the second group of digits: year 2009 ("
(tt "09")
" + 2000), month "
(tt "06")
", day of month "
(tt "20")
". The "
(racket decode-roomba-manufacturing-code)
" procedure can do this for you.")
(para "This package does not presently work on the Roomba 700 series,
since iRobot has not documented the protocol for that series, unlike for the
400 series, 500 series, and the Create. However, a 700 series user reported
that the 700 seems to provide a serial protocol similar to SCI and OI, but
somewhat different. So, given access to a 700 series, the protocol might not
be too hard to understand and support in a future version of this package.
Realistically, someone who can afford a 700 series can probably also afford a
$50 used 400 series for hobby purposes, so 700 support seems a low priority.
All that said, the author of this package welcomes expensive gifts at any time
of year.")
(para "Note that this package does not work on iRobot Scooba, even though
the Scooba has a mini-DIN connector, since it reportedly uses a different
protocol than the Roombas and the Create. The Scooba's protocol might not even
be for control, but only for firmware updating."))
(doc (defproc (decode-roomba-manufacturing-code (str string?))
(listof (cons/c symbol? any/c))
(para "Decodes a manufacturing code from a barcode label found on the
Roomba and its box, returning the information as a human-readable alist. For
example:")
(racketinput (decode-roomba-manufacturing-code "JEN041100610060012345"))
(racketresultblock '((manufacturer . jetta)
(status . new)
(model . 4110)
(date . #(2006 10 6))
(rev . 0)
(serial . 12345)))
(para "The decoding is based on information from a "
(hyperlink "http://www.robotreviews.com/chat/viewtopic.php?f=1&t=16354#p110177"
"2006-12-29 robotreviews.com post by newmom")
".")))
(provide decode-roomba-manufacturing-code)
(define decode-roomba-manufacturing-code
(let ((rx (regexp (string-append "^"
"([A-Z][A-Z])"
"([RN])"
"([0-9][0-9][0-9][0-9][0-9])"
"([0-9][0-9])"
"([0-9][0-9])"
"([0-9][0-9])"
"([0-9][0-9])"
"([0-9][0-9][0-9][0-9][0-9])"
"$"))))
(lambda (str)
(let ((str (string-upcase (regexp-replace* #rx"[ \t\r\n]+" str ""))))
(cond ((regexp-match rx str)
=> (lambda (m)
(apply (lambda (all mfgr status model year month mday rev serial)
`((manufacturer . ,(or (hash-ref #hash(("JE" . jetta)
("PR" . prc))
mfgr
#f)
mfgr))
(status . ,(or (hash-ref #hash(("N" . new)
("R" . refurbished))
status
#f)
status))
(model . ,(string->number model))
(date . ,(vector (+ 2000 (string->number year))
(string->number month)
(string->number mday)))
(rev . ,(string->number rev))
(serial . ,(string->number serial))))
m)))
(else (error 'decode-roomba-manufacturing-code
"could not decode ~S"
str)))))))
(module+ test
(test (decode-roomba-manufacturing-code "JEN 04000 090620 08 12345")
'((manufacturer . jetta)
(status . new)
(model . 4000)
(date . #(2009 6 20))
(rev . 8)
(serial . 12345)))
(test (decode-roomba-manufacturing-code "JEN041100610060012345")
'((manufacturer . jetta)
(status . new)
(model . 4110)
(date . #(2006 10 6))
(rev . 0)
(serial . 12345))))
(define (%roomba-model-struct-write-proc roomba-model port write?)
(fprintf port
"#<roomba-model ~S>"
(roomba-model-struct-number roomba-model)))
(doc (defproc (roomba-model? (x any/c))
boolean?
(para "Predicate for a Roomba model.")))
(provide (rename-out (roomba-model-struct? roomba-model?)
(roomba-model-struct-number roomba-model-number)
(roomba-model-struct-generation roomba-model-generation)
(roomba-model-struct-protocol roomba-model-protocol)))
(define-struct roomba-model-struct
(number
generation
protocol)
#:methods
gen:custom-write ((define write-proc %roomba-model-struct-write-proc)))
(doc (defproc (make-roomba-model (#:number number (or/c exact-nonnegative-integer? symbol?))
(#:generation generation (or/c #f 1 2 3 4))
(#:protocol protocol roomba-protocol?))
roomba-model?
(para "Make a new "
(racket roomba-model)
" object, for situations in which this package does not already
provide an appropriate pre-defined object. (Perhaps you will also email the
author/maintainer of this package, so that the model can be added for everyone
else.)")))
(provide (rename-out (%make-roomba-model/kw make-roomba-model)))
(define (%make-roomba-model/kw #:number number
#:generation generation
#:protocol protocol)
(make-roomba-model-struct number
generation
protocol))
(doc (defparam current-number-to-roomba-model-hash
hasheqv
(hash/c (or/c exact-nonnegative-integer? symbol?)
roomba-model?)
(para "Parameter for a hash that maps Roomba model numbers to "
(racket roomba-model)
" objects. By default, it is populated with the following model numbers:")
(itemlist (item "Second Generation --- "
(racket 'second-generation
1100
'series-4000
'series-400
4000
400
4100
410
4105
416
4110
'sagelike-4130
'discolike-4130
4150
4170
4188
4210
4220
4225
4230
4260))
(item "500 Series --- "
(racket 'series-500
510
530
532
535
550
560
562
564
570
571
572
580
581))
(item "600 Series --- "
(racket 'series-600
610
620
630
650
660))
(item "Create --- "
(racket 'create
4400
4418)))
(para "Note that some second generations need a firmware update before
they'll work with this package. See the documentation for "
(racket roomba-sci)
".")
(para "The list of model numbers is mostly based on the ``"
(hyperlink "http://en.wikipedia.org/wiki/Roomba#List_of_models"
"List of models")
"'' section of the Wikipedia page on Roomba.")))
(provide current-number-to-roomba-model-hash)
(define current-number-to-roomba-model-hash
(make-parameter
(make-immutable-hasheqv
(map (lambda (model)
(cons (roomba-model-struct-number model) model))
(list
(make-roomba-model-struct 'second-generation 2 roomba-sci)
(make-roomba-model-struct 1100 2 roomba-sci)
(make-roomba-model-struct 'series-4000 2 roomba-sci)
(make-roomba-model-struct 'series-400 2 roomba-sci)
(make-roomba-model-struct 4000 2 roomba-sci)
(make-roomba-model-struct 400 2 roomba-sci)
(make-roomba-model-struct 4100 2 roomba-sci)
(make-roomba-model-struct 410 2 roomba-sci)
(make-roomba-model-struct 4105 2 roomba-sci)
(make-roomba-model-struct 416 2 roomba-sci)
(make-roomba-model-struct 4110 2 roomba-sci)
(make-roomba-model-struct 'sagelike-4130 2 roomba-sci)
(make-roomba-model-struct 'discolike-4130 2 roomba-sci)
(make-roomba-model-struct 4150 2 roomba-sci)
(make-roomba-model-struct 4170 2 roomba-sci)
(make-roomba-model-struct 4188 2 roomba-sci)
(make-roomba-model-struct 4210 2 roomba-sci)
(make-roomba-model-struct 4220 2 roomba-sci)
(make-roomba-model-struct 4225 2 roomba-sci)
(make-roomba-model-struct 4230 2 roomba-sci)
(make-roomba-model-struct 4260 2 roomba-sci)
(make-roomba-model-struct 'series-500 3 roomba-roi)
(make-roomba-model-struct 510 3 roomba-roi)
(make-roomba-model-struct 530 3 roomba-roi)
(make-roomba-model-struct 532 3 roomba-roi)
(make-roomba-model-struct 535 3 roomba-roi)
(make-roomba-model-struct 550 3 roomba-roi)
(make-roomba-model-struct 560 3 roomba-roi)
(make-roomba-model-struct 562 3 roomba-roi)
(make-roomba-model-struct 564 3 roomba-roi)
(make-roomba-model-struct 570 3 roomba-roi)
(make-roomba-model-struct 571 3 roomba-roi)
(make-roomba-model-struct 572 3 roomba-roi)
(make-roomba-model-struct 580 3 roomba-roi)
(make-roomba-model-struct 581 3 roomba-roi)
(make-roomba-model-struct 'series-600 3 roomba-roi)
(make-roomba-model-struct 610 3 roomba-roi)
(make-roomba-model-struct 620 3 roomba-roi)
(make-roomba-model-struct 630 3 roomba-roi)
(make-roomba-model-struct 650 3 roomba-roi)
(make-roomba-model-struct 660 3 roomba-roi)
(make-roomba-model-struct 'create 2 roomba-coi)
(make-roomba-model-struct 4400 2 roomba-coi)
(make-roomba-model-struct 4418 2 roomba-coi)
)))))
(doc (defparam current-default-roomba-model
model
(or/c roomba-model? exact-nonnegative-integer? symbol?))
(para "Parameter for the default "
(racket roomba-model)
", which is used by "
(racket open-roomba)
", "
(racket with-roomba)
", and perhaps other procedures and syntax. The default value of
this is "
(racket 'create)
", meaning the iRobot Create platform in general. You might wish to
change this parameter to something else, like "
(racket 'second-generation)
" or an exact model number."))
(provide current-default-roomba-model)
(define current-default-roomba-model (make-parameter 'create))
(define (%resolve-roomba-model-or-number
model
#:error-name (error-name '%resolve-roomba-model-or-number))
(if (roomba-model-struct? model)
model
(hash-ref (current-number-to-roomba-model-hash)
model
(lambda ()
(error error-name
"invalid roomba-model or number: ~S"
model)))))
(module+ test
(test (format "~S" (%resolve-roomba-model-or-number 400))
"#<roomba-model 400>")
(test (format "~S" (%resolve-roomba-model-or-number 'create))
"#<roomba-model create>"))
(doc (section "Roomba Object")
(para "There is a "
(racket roomba)
" object that represents a connection to the robot. This can be an
explicit argument to each operation on the robot, but there is also a "
(racket current-roomba)
" Racket parameter that is the default robot when it is not given as
an argument."))
(define (%roomba-struct-write-proc roomba port write?)
(fprintf port
"#<roomba ~S ~S>"
(cond ((roomba-struct-name roomba) => (lambda (x) x))
((roomba-struct-model roomba) => roomba-model-struct-number)
(else #f))
(roomba-struct-mode roomba)))
(doc (defproc (roomba? (x any/c))
boolean?
(para "Predicate for the "
(racket roomba)
" object.")))
(provide (rename-out (roomba-struct? roomba?)))
(define-struct roomba-struct
((name)
(model)
(protocol)
(protocol-symbol)
(device)
(in)
(out)
(mode #:mutable))
#:methods
gen:custom-write ((define write-proc %roomba-struct-write-proc)))
(doc (defproc (get-roomba-name (#:roomba roomba roomba? (current-roomba)))
roomba-name?
(para "Returns the current name of the "
(racket roomba)
", as supplied by the optional "
(racket #:name)
" argument to a procedure like "
(racket open-roomba)
".")))
(provide get-roomba-name)
(define (get-roomba-name #:roomba (roomba (current-roomba)))
(roomba-struct-name roomba))
(doc (defparam current-roomba
roomba
roomba?
(para "Parameter for the "
(racket roomba)
" that is the default for command procedures. This parameter is
usually set automatically by "
(racket open-roomba)
", but can also be set manually, like a normal Racket parameter.")))
(provide current-roomba)
(define current-roomba
(make-parameter #f))
(doc (section "Opening and Closing"))
(doc (defparam current-default-roomba-device
path
path-string?
(para "Parameter that is the default "
(deftech "device")
", which is normally a special operating system device file for
the serial port device through which the Roomba is accessed. This parameter
defaults to a value like "
(racket "/dev/ttyS0")
", depending on the Racket platform.")))
(provide current-default-roomba-device)
(define current-default-roomba-device
(make-parameter (case (system-type 'os)
((macosx) "/dev/tty.usbserial")
(else "/dev/ttyS0"))))
(define (%roomba-args-int16 error-name variable-name arg)
(if (and (integer? arg)
(<= -32768 arg 32767))
(let ((arg (if (exact? arg)
arg
(inexact->exact arg))))
(let ((bstr (integer->integer-bytes arg 2 #true #true)))
(values (bytes-ref bstr 0)
(bytes-ref bstr 1))))
(error error-name
"expected ~S to be 16-bit integer, got ~S"
variable-name
arg)))
(module+ test
(test-section '%roomba-args-int16
(test 'from-sci-spec-1
(%roomba-args-int16 'my-error-name 'my-variable-name -200)
(values #xff #x38))
(test 'from-sci-spec-2
(%roomba-args-int16 'my-error-name 'my-variable-name 500)
(values #x01 #xf4))))
(define (%roomba-args-one error-name variable-name arg permissible)
(if (member arg permissible)
arg
(error error-name
"expected ~S to be one of ~S, got ~S"
variable-name
permissible
arg)))
(define (%roomba-arg-song-number error-name variable-name arg)
(if (and (integer? arg)
(<= 0 arg 15))
arg
(error error-name
"expected ~S to be a valid song number (0-15), got ~S"
variable-name
arg)))
(define (%roomba-mode-change-with-delay roomba mode)
(log-roomba-debug "(%roomba-mode-change-with-delay ~S ~S)" roomba mode)
(set-roomba-struct-mode! roomba mode)
(sleep 30/1000))
(define (%assert-roomba-mode error-name roomba expected-modes)
(let ((actual-mode (roomba-struct-mode roomba)))
(if (memq actual-mode expected-modes)
(void)
(raise (make-exn:fail:roomba:mode
(format "~S: expected ~S to be in modes ~S, but actually in mode ~S"
error-name
roomba
expected-modes
actual-mode)
(current-continuation-marks)
roomba
expected-modes
actual-mode)))))
(define (%send-byte-to-roomba roomba command-byte)
(log-roomba-debug "(%send-byte-to-roomba ~S ~S)" roomba command-byte)
(with-handlers* ((exn:fail? (lambda (e)
(close-roomba #:roomba roomba)
(raise (make-exn:fail:roomba:io
(format "%send-byte-to-roomba: error sending ~S command ~S: ~A"
roomba
command-byte
(exn-message e))
(exn-continuation-marks e)
roomba)))))
(let ((out (roomba-struct-out roomba)))
(write-byte command-byte out)
(flush-output out))))
(define (%send-byte-string-to-roomba roomba command-bytes)
(log-roomba-debug "(%send-byte-string-to-roomba ~S ~S)" roomba command-bytes)
(with-handlers* ((exn:fail? (lambda (e)
(close-roomba #:roomba roomba)
(raise (make-exn:fail:roomba:io
(format "%send-byte-string-to-roomba: error sending ~S command ~S: ~A"
roomba
command-bytes
(exn-message e))
(exn-continuation-marks e)
roomba)))))
(let ((out (roomba-struct-out roomba)))
(write-bytes command-bytes out)
(flush-output out))))
(define (%send-byte-list-to-roomba roomba byte-list)
(log-roomba-debug "(%send-byte-list-to-roomba ~S ~S)" roomba byte-list)
(%send-byte-string-to-roomba roomba (apply bytes byte-list)))
(define (%read-byte-string-from-roomba roomba read-size)
(log-roomba-debug "(%read-byte-string-from-roomba ~S ~S)" roomba read-size)
(with-handlers* ((exn:fail? (lambda (e)
(close-roomba #:roomba roomba)
(raise (make-exn:fail:roomba:io
(format "%read-byte-string-from-roomba: error reading ~S bytes from ~S: ~A"
read-size
roomba
(exn-message e))
(exn-continuation-marks e)
roomba)))))
(read-bytes read-size (roomba-struct-in roomba))))
(define (%get-roomba-stty-minus-f-arg-string)
(case (system-type 'os)
((macosx) "-f")
(else "-F")))
(doc (defproc (open-roomba
(#:name name (or/c #f string?) #f)
(#:model model (or/c roomba-model? exact-nonnegative-integer? symbol?) (current-roomba-default-model))
(#:device device path-string? (current-default-roomba-device))
(#:set-current? set-current? boolean? #true))
roomba)
(para "Opens a connection to a Roomba, and returns an object for the
connection. If "
(racket set-current?)
" is true, then "
(racket current-roomba)
" is also set to the object."))
(provide open-roomba)
(define (open-roomba
#:name (name #f)
#:model (model (current-default-roomba-model))
#:device (device (current-default-roomba-device))
#:set-current? (set-current? #true))
(log-roomba-debug "(open-roomba #:device ~S #:set-current? ~S)"
device
set-current?)
(let* ((model (%resolve-roomba-model-or-number model #:error-name 'open-roomba))
(device (path->string (cleanse-path device)))
(protocol (roomba-model-struct-protocol model))
(device-baud (roomba-protocol-struct-default-baud protocol))
(device-data-bits 8)
(device-parity #false)
(device-stop-bits 1)
(args `("/bin/stty"
,(%get-roomba-stty-minus-f-arg-string)
,device
,(number->string device-baud)
"raw"
"-echo"
"clocal"
,(string-append "cs" (number->string device-data-bits))
,@(if device-parity
`("parenb"
,(case device-parity
((even) "-parodd")
((odd) "parodd")
(else (error 'open-roomba
"invalid device-parity ~S"
device-parity))))
'("-parenb"
"-parodd"))
,(case device-stop-bits
((1) "-cstopb")
((2) "cstopb")
(else (error 'open-roomba
"invalid device-stop-bits ~S"
device-stop-bits)))
"-hupcl"
"-crtscts"
"-onlcr"
"-iexten"
"-echok"
"-echoe"
"-echoctl"
"-echoke"
)))
(log-roomba-debug "open-roomba: initializing device with command ~S" args)
(or (apply system*
args)
(error 'open-roomba
"stty ~S failed"
device))
(log-roomba-debug "open-roomba: opening device file")
(let-values (((in out) (with-handlers* ((exn:fail? (lambda (e)
(with-handlers ((exn:fail? void))
(raise e)))))
(open-input-output-file device #:exists 'update))))
(log-roomba-debug "open-roomba: device file is open")
(file-stream-buffer-mode in 'none)
(file-stream-buffer-mode out 'none)
(let* ((protocol (roomba-model-struct-protocol model))
(roomba (make-roomba-struct name
model
protocol
(roomba-protocol-struct-symbol protocol)
device
in
out
#f)))
(log-roomba-debug "open-roomba: pausing 500ms")
(sleep 500/1000)
(log-roomba-debug "open-roomba: sending start command")
(%send-byte-to-roomba roomba 128)
(%roomba-mode-change-with-delay roomba 'passive)
(log-roomba-debug "open-roomba: sending safe/control command")
(%send-byte-to-roomba roomba
(roomba-protocol-struct-post-start-opcode protocol))
(%roomba-mode-change-with-delay roomba 'safe)
(if set-current?
(begin (log-roomba-debug "open-roomba: setting current-roomba")
(current-roomba roomba))
(log-roomba-debug "open-roomba: not setting current-roomba"))
(log-roomba-debug "open-roomba: returning")
roomba))))
(doc (defproc (close-roomba (#:roomba roomba roomba? (current-roomba)))
void?
(para "Closes the connection to the Roomba, if not already closed.
Changes the "
(tech "mode")
" to "
(racket 'closed)
".")))
(provide close-roomba)
(define (close-roomba #:roomba (roomba (current-roomba)))
(log-roomba-debug "(close-roomba #:roomba ~S)" roomba)
(if (eq? 'closed (roomba-struct-mode roomba))
(log-roomba-warning "close-roomba: already closed")
(begin (set-roomba-struct-mode! roomba 'closed)
(with-handlers ((exn:fail? (lambda (e)
(log-roomba-warning "close-roomba: error closing input port: ~S"
(exn-message e)))))
(close-input-port (roomba-struct-in roomba)))
(with-handlers ((exn:fail? (lambda (e)
(log-roomba-warning "close-roomba: error closing output port: ~S"
(exn-message e)))))
(close-output-port (roomba-struct-out roomba)))
)))
(doc (defform (with-roomba maybe-name
maybe-model
maybe-device
body ...+)
#:grammar ((maybe-name code:blank
(code:line #:name string?))
(maybe-model code:blank
(code:line #:model (or/c roomba-model?
exact-nonnegative-integer?
symbol?)))
(maybe-device code:blank
(code:line #:device string?)))
(para "This is a convenience for calling "
(racket open-roomba)
" and "
(racket close-roomba)
". In most cases, "
(racket close-roomba)
" will be called even if the body is exited due to an exception.")))
(provide with-roomba)
(define-syntax (with-roomba stx)
(syntax-parse stx
((_ (~optional (~seq #:name NAME))
(~optional (~seq #:model MODEL))
(~optional (~seq #:device DEVICE))
BODYn ...+)
(with-syntax ((NAME (or (attribute NAME) (syntax/loc stx #f)))
(MODEL (or (attribute MODEL) (syntax/loc stx (current-default-roomba-model))))
(DEVICE (or (attribute DEVICE) (syntax/loc stx (current-default-roomba-device)))))
#'(let ((roomba (open-roomba #:name NAME
#:model (%resolve-roomba-model-or-number MODEL #:error-name 'with-roomba)
#:device DEVICE
#:set-current? #false)))
(dynamic-wind void
(lambda ()
(parameterize ((current-roomba roomba))
BODYn ...))
(lambda ()
(close-roomba #:roomba roomba))))))))
(doc (section "Modes")
(para "A Roomba "
(deftech "mode")
" is a general operating mode of the Roomba. The modes are
identified in this package by a symbol:")
(itemlist (item (racket 'off)
" --- Powered off or sleeping, and you probably need to
manually press a button to wake it up.")
(item (racket 'passive)
" --- Sensors can be read, but cannot be controlled in
this mode.")
(item (racket 'safe)
" --- Can be controlled. Lift and cliff sensors, or
plugging into charger, "
(italic "do")
" trigger switch to "
(racket 'passive)
" mode. "
(racket 'safe)
" is the usual mode for most purposes.")
(item (racket 'full)
" --- Can be controlled. Lift and cliff sensors, and
charger plugging do "
(italic "not")
" switch Roomba to "
(racket 'passive)
" mode. Switching to "
(racket 'full)
" mode also stops any battery charging. Don't use "
(racket 'full)
" mode unless you're sure you need to, and you can cover
the safety risks other ways.")
(item (racket 'closed)
" --- This connection with the Roomba is closed, so this
connection does not know the mode. The mode is changed to this when "
(racket close-roomba)
" is called, when "
(racket with-roomba)
" exits, or when an I/O error occurs when attempting to
talk with the Roomba.")))
(doc (defproc (roomba-mode? (x any/c))
boolean?
(para "Predicate for "
(tech "mode")
".")))
(provide roomba-mode?)
(define (roomba-mode? x)
(and (member x '(off passive safe full)) #true))
(doc (defproc (get-roomba-mode (#:roomba roomba roomba? (current-roomba)))
roomba-mode?
(para "Returns the current "
(tech "mode")
" of the Roomba, as cached in the "
(racket roomba)
" object (without talking to the robot).")))
(provide get-roomba-mode)
(define (get-roomba-mode #:roomba (roomba (current-roomba)))
(roomba-struct-mode roomba))
(doc (defproc (set-roomba-mode (#:roomba roomba roomba? (current-roomba))
(#:mode mode (or/c 'safe 'full 'off)))
void?
(para "Changes the "
(tech "mode")
" of the Roomba. This sends mode change commands to the Roomba,
not merely changes the believed mode in the "
(racket roomba)
" object. Works in modes: "
(racket 'passive)
", "
(racket 'safe)
", "
(racket 'full)
".")))
(provide set-roomba-mode)
(define (set-roomba-mode #:roomba (roomba (current-roomba))
#:mode mode)
(log-roomba-debug "(set-roomba-mode #:roomba ~S #:mode ~S)" roomba mode)
(%assert-roomba-mode 'set-roomba-mode roomba '(passive safe full))
(case mode
((safe)
(%send-byte-to-roomba roomba 131)
(%roomba-mode-change-with-delay roomba 'safe))
((full)
(%send-byte-to-roomba roomba 132)
(%roomba-mode-change-with-delay roomba 'full))
((off)
(%send-byte-to-roomba roomba 133)
(%roomba-mode-change-with-delay roomba 'off))
(else (error 'set-roomba-mode
"invalid mode ~S"
mode))))
(doc (section "Stock Behaviors"))
(doc (subsection "Cleaning"))
(doc (defproc (start-roomba-spot-clean (#:roomba roomba roomba? (current-roomba)))
void?
(para "Like pressing the Spot button, starts a spot-cleaning, and
switches to "
(racket 'passive)
" mode. Works in
modes: "
(racket 'safe)
", "
(racket 'full)
".")))
(provide start-roomba-spot-clean)
(define (start-roomba-spot-clean #:roomba (roomba (current-roomba)))
(log-roomba-debug "(start-roomba-spot-clean #:roomba ~S)" roomba)
(%assert-roomba-mode 'start-roomba-spot-clean roomba '(safe full))
(%send-byte-to-roomba roomba 134)
(%roomba-mode-change-with-delay roomba 'passive))
(doc (defproc (start-roomba-clean (#:roomba roomba roomba? (current-roomba)))
void?
(para "Like pressing the Clean button, starts a normal cleaning cycle,
and switches to "
(racket 'passive)
" mode. Works in
modes: "
(racket 'safe)
", "
(racket 'full)
".")))
(provide start-roomba-clean)
(define (start-roomba-clean #:roomba (roomba (current-roomba)))
(log-roomba-debug "(start-roomba-clean #:roomba ~S)" roomba)
(%assert-roomba-mode 'roomba-clean roomba '(safe full))
(%send-byte-to-roomba roomba 135)
(%roomba-mode-change-with-delay roomba 'passive))
(doc (defproc (start-roomba-max-clean (#:roomba roomba roomba? (current-roomba)))
void?
(para "Like pressing the Max button, starts a maximum-time cleaning cycle,
and switches to "
(racket 'passive)
" mode. Works in
modes: "
(racket 'safe)
", "
(racket 'full)
".")))
(provide start-roomba-max-clean)
(define (start-roomba-max-clean #:roomba (roomba (current-roomba)))
(log-roomba-debug "(start-roomba-max-clean #:roomba ~S)" roomba)
(%assert-roomba-mode 'start-roomba-max-clean roomba '(safe full))
(%send-byte-to-roomba roomba 136)
(%roomba-mode-change-with-delay roomba 'passive))
(doc (subsection "Docking"))
(doc (defproc (start-roomba-seek-dock (#:roomba roomba roomba? (current-roomba)))
void?
(para "Directs the Roomba to start seeking its dock. This might only
work during some kind of cleaning cycle.")))
(provide start-roomba-seek-dock)
(define (start-roomba-seek-dock #:roomba (roomba (current-roomba)))
(log-roomba-debug "(start-roomba-seek-dock #:roomba ~S)" roomba)
(%assert-roomba-mode 'start-roomba-max-clean roomba '(safe full))
(%send-byte-to-roomba roomba 143))
(doc (section "Driving"))
(doc (defproc (set-roomba-drive (#:roomba roomba roomba? (current-roomba))
(#:velocity-mm/s velocity-mm/s integer?)
(#:radius-mm radius-mm ((or/c #f integer?) #f)))
void?
(para "Sets the drive speed and turning radius of the Roomba.")
(para (racket velocity-mm/s)
" is the velocity in millimeters per second, with a range of "
(racket -500)
" to "
(racket +500)
", with negative numbers meaning to drive in reverse.")
(para (racket radius-mm)
" is the turning radius in millimeters, with a range of "
(racket -2000)
" to "
(racket +2000)
", or "
(racket #f)
", meaning straight.")))
(provide set-roomba-drive)
(define (set-roomba-drive #:roomba (roomba (current-roomba))
#:velocity-mm/s velocity-mm/s
#:radius-mm (radius-mm #f))
(log-roomba-debug "(set-roomba-drive #:roomba ~S #:velocity-mm/s ~S #:radius-mm ~S)"
roomba
velocity-mm/s
radius-mm)
(%assert-roomba-mode 'set-roomba-drive roomba '(safe full))
(let-values (((velocity-1 velocity-2) (%roomba-args-int16 'set-roomba-drive 'velocity-mm/s velocity-mm/s))
((radius-1 radius-2) (if radius-mm
(%roomba-args-int16 'set-roomba-drive 'radius-mm radius-mm)
(values #x80 #x00))))
(%send-byte-string-to-roomba roomba (bytes 137 velocity-1 velocity-2 radius-1 radius-2))))
(doc (section "Motors"))
(doc (defproc (set-roomba-motors (#:roomba roomba roomba? (current-roomba))
(#:side-brush? side-brush? boolean? #false)
(#:vacuum? vacuum? boolean? #false)
(#:main-brush? main-brush? boolean? #false))
void?
(para "Sets the on/off states of each of the Roomba's motors, other than
the drive motors. When they keyword argument for a motor is not provided, the default is "
(racket #false)
" (i.e., off).")))
(provide set-roomba-motors)
(define (set-roomba-motors #:roomba (roomba (current-roomba))
#:side-brush? (side-brush? #false)
#:vacuum? (vacuum? #false)
#:main-brush? (main-brush? #false))
(log-roomba-debug "(set-roomba-motors #:roomba ~S #:side-brush? ~S #:vacuum? ~S #:main-brush ~S)"
roomba
side-brush?
vacuum?
main-brush?)
(%assert-roomba-mode 'set-roomba-motors roomba '(safe full))
(%send-byte-string-to-roomba roomba
(bytes 138
(bitwise-ior (if side-brush? #b001 0)
(if vacuum? #b010 0)
(if main-brush? #b100 0)))))
(doc (section "Lights"))
(doc (defproc (set-roomba-leds (#:roomba roomba roomba? (current-roomba))
(#:debris? debris? boolean? #false)
(#:max? max? boolean? #false)
(#:clean? clean? boolean? #false)
(#:spot? spot? boolean? #false)
(#:dock? dock? boolean? #false)
(#:check? check? boolean? #false)
(#:play? play? boolean? #false)
(#:advance? advance? boolean? #false)
(#:status status (or/c #f 'red 'green 'amber) #false)
(#:power-color power-color byte? 0)
(#:power-intensity power-intensity byte? 0))
void?
(para "Sets the states of all the LEDs on the Roomba at once.")
(para "The follow table shows which series of Roomba "
(tech "models")
" support which variables, and how the corresponding LEDs are
usually labeled. Note that not all models of a series have all LEDs that the
series supports. Attempting to set a non-existent LED through this procedure
has no effect, not even a warning.")
(nested #:style 'inset
(tabular #:sep (hspace 2)
(list
(list (bold "Variable") (bold "Labels") (bold "Series"))
(list (racket debris?) "Dirt Detect, Dirt Alert, Debris" "2nd, 500, 600")
(list (racket max?) "Max" "2nd")
(list (racket clean?) "Clean" "2nd")
(list (racket spot?) "Spot" "2nd, 500, 600")
(list (racket dock?) "Dock" "500, 600")
(list (racket check?) "Check Robot" "500, 600")
(list (racket play?) "Play" "Create")
(list (racket advance?) "Advance" "Create")
(list (racket status) "Status" "2nd")
(list (elem (racket power-color)
", "
(linebreak)
(racket power-intensity))
"Power (Clean)"
"2nd, 500, Create"))))
(para "The Boolean LEDs are self-explanatory.")
(para (racket status)
" is one of 3 colors, or "
(racket #f)
" for off.")
(para (racket power-color)
" is a value from 0 to 255, representing a color from green to red.")
(para (racket power-intensity)
" is a value from 0 to 255, representing a range from off to full
intensity.")
(para "Note that not all Roomba models have all these LEDs. The LEDs
that they do have might be labeled differently between models.")))
(provide set-roomba-leds)
(define (set-roomba-leds #:roomba (roomba (current-roomba))
#:debris? (debris? #false)
#:max? (max? #false)
#:clean? (clean? #false)
#:spot? (spot? #false)
#:dock? (dock? #false)
#:check? (check? #false)
#:play? (play? #false)
#:advance? (advance? #false)
#:status (status #false)
#:power-color (power-color 0)
#:power-intensity (power-intensity 0))
(log-roomba-debug "(set-roomba-leds #:roomba ~S #:debris? ~S #:max? ~S #:play? ~S #:clean? ~S #:spot? ~S #:advance? ~S #:status ~S #:power-color ~S #:power-intensity ~S)"
roomba
debris?
max?
play?
clean?
spot?
advance?
status
power-color
power-intensity)
(%assert-roomba-mode 'set-roomba-leds roomba '(safe full))
(%send-byte-string-to-roomba
roomba
(bytes 139
(let ((proto (roomba-struct-protocol-symbol roomba)))
(case proto
((roomba-sci)
(bitwise-ior (if debris? #b00000001 0)
(if max? #b00000010 0)
(if clean? #b00000100 0)
(if spot? #b00001000 0)
(case status
((#f) 0)
((red) #b00010000)
((green) #b00100000)
((amber) #b00110000)
(else (error 'set-roomba-leds
"invalid status ~S"
status)))))
((roomba-roi)
(bitwise-ior (if debris? #b00000001 0)
(if spot? #b00000010 0)
(if dock? #b00000100 0)
(if check? #b00001000 0)))
((roomba-coi)
(bitwise-ior (if play? #b00000010 0)
(if advance? #b00001000 0)))
(else (error 'set-roomba-leds
"invalid roomba-protocol-symbol ~S"
proto))))
power-color power-intensity )))
(doc (section "Sound")
(para "The Roomba permits short songs by stored in numbered memory slots
and then played back on command. The songs consist of single-voice notes with
durations, and the volume is fixed.")
(para "This library provides a "
(deftech "song language")
" for describing songs to be stored, with the BNF grammar:")
(BNF (list (nonterm "song-language")
(BNF-seq (litchar "(")
(kleeneplus (nonterm "note"))
(litchar ")")))
(list (nonterm "note")
(nonterm "frequency")
(BNF-seq (litchar "(")
(nonterm "frequency")
(nonterm "duration")
(litchar ")")))
(list (nonterm "frequency")
(italic (racket symbol?))
(italic (racket number?)))
(list (nonterm "duration")
(litchar "whole")
(litchar "w")
(litchar "half")
(litchar "h")
(litchar "quarter")
(litchar "q")
(italic (racket number?))))
(para "For "
(nonterm "frequency")
", usually you will use a symbol like "
(racket 'c4)
" or "
(racket 'cs4)
", in the manner of "
(hyperlink "http://en.wikipedia.org/wiki/Common_Music_Notation"
"Common Music Notation")
" (CMN). You can also use single-letter note symbols, like "
(racket 'c)
". If a number is given, it's the frequency that this library tries
to approximate on the Roomba.")
(para "For "
(nonterm "duration")
", symbols like "
(racket 'whole)
" and "
(racket 'h)
" denote whole and half notes, respectively. If the duration for a
note is not given, a quarter note is assumed. If the duration is given as a
number, it's in 64ths of a second.")
(para "For example, here's a start of Mary Had a Little Lamb:")
(racketblock '(b a g a b b (b h) a a (a h) b d (d h))))
(doc (defproc (roomba-song-language? (x any/c))
boolean?
(para "Predicate for "
(tech "song language")
". This predicate does not necessarily do a complete check of "
(racket x)
", and is mainly here for documentation purposes.")))
(provide roomba-song-language?)
(define (roomba-song-language? x)
(pair? x))
(doc (defproc (roomba-song-number? (x any/c))
boolean?
(para "Predicate for "
(deftech "song number")
", which is an exact nonnegative integer in the range of 0 to 15.
This is used to identify a song storage slot on the Roomba.")))
(provide roomba-song-number?)
(define (roomba-song-number? x)
(and (exact-nonnegative-integer? x)
(<= 0 x 15)))
(define-values (%symbol-to-roomba-note-number-hash
%frequency-to-roomba-note-number-alist)
(let ((notes '((c0 16.352 #false 31)
(cs0 17.324 #false 31)
(d0 18.354 #false 31)
(ds0 19.445 #false 31)
(e0 20.602 #false 31)
(f0 21.827 #false 31)
(fs0 23.125 #false 31)
(g0 24.5 #false 31)
(gs0 25.957 #false 31)
(a0 27.5 #false 31)
(as0 29.135 #false 31)
(b0 30.868 #false 31)
(c1 32.703 #false 31)
(cs1 34.648 #false 31)
(d1 36.708 #false 31)
(ds1 38.891 #false 31)
(e1 41.203 #false 31)
(f1 43.654 #false 31)
(fs1 46.249 #false 31)
(g1 48.999 #true 31)
(gs1 51.913 #true 32)
(a1 55.0 #true 33)
(as1 58.27 #true 34)
(b1 61.735 #true 35)
(c2 65.406 #true 36)
(cs2 69.296 #true 37)
(d2 73.416 #true 38)
(ds2 77.782 #true 39)
(e2 82.407 #true 40)
(f2 87.307 #true 41)
(fs2 92.499 #true 42)
(g2 97.999 #true 43)
(gs2 103.83 #true 44)
(a2 110.0 #true 45)
(as2 116.54 #true 46)
(b2 123.47 #true 47)
(c3 130.81 #true 48)
(cs3 138.59 #true 49)
(d3 146.83 #true 50)
(ds3 155.56 #true 51)
(e3 164.81 #true 52)
(f3 174.61 #true 53)
(fs3 185.0 #true 54)
(g3 196.0 #true 55)
(gs3 207.65 #true 56)
(a3 220.0 #true 57)
(as3 233.08 #true 58)
(b3 246.94 #true 59)
(c4 261.63 #true 60)
(cs4 277.18 #true 61)
(d4 293.66 #true 62)
(ds4 311.13 #true 63)
(e4 329.63 #true 64)
(f4 349.23 #true 65)
(fs4 369.99 #true 66)
(g4 392.0 #true 67)
(gs4 415.3 #true 68)
(a4 440.0 #true 69)
(as4 466.16 #true 70)
(b4 493.88 #true 71)
(c5 523.25 #true 72)
(cs5 554.37 #true 73)
(d5 587.33 #true 74)
(ds5 622.25 #true 75)
(e5 659.26 #true 76)
(f5 698.46 #true 77)
(fs5 739.99 #true 78)
(g5 783.99 #true 79)
(gs5 830.61 #true 80)
(a5 880.0 #true 81)
(as5 932.33 #true 82)
(b5 987.77 #true 83)
(c6 1046.5 #true 84)
(cs6 1108.7 #true 85)
(d6 1174.7 #true 86)
(ds6 1244.5 #true 87)
(e6 1318.5 #true 88)
(f6 1396.9 #true 89)
(fs6 1480.0 #true 90)
(g6 1568.0 #true 91)
(gs6 1661.2 #true 92)
(a6 1760.0 #true 93)
(as6 1864.7 #true 94)
(b6 1975.5 #true 95)
(c7 2093.0 #true 96)
(cs7 2217.5 #true 97)
(d7 2349.3 #true 98)
(ds7 2489.0 #true 99)
(e7 2637.0 #true 100)
(f7 2793.8 #true 101)
(fs7 2960.0 #true 102)
(g7 3136.0 #true 103)
(gs7 3322.4 #true 104)
(a7 3520.0 #true 105)
(as7 3729.3 #true 106)
(b7 3951.1 #true 107)
(c8 4186.0 #true 108)
(cs8 4434.9 #true 109)
(d8 4698.6 #true 110)
(ds8 4978.0 #true 111)
(e8 5274.0 #true 112)
(f8 5587.7 #true 113)
(fs8 5919.9 #true 114)
(g8 6271.9 #true 115)
(gs8 6644.9 #true 116)
(a8 7040.0 #true 117)
(as8 7458.6 #true 118)
(b8 7902.1 #true 119)
(c9 8372.0 #true 120)
(cs9 8869.8 #true 121)
(d9 9397.3 #true 122)
(ds9 9956.1 #true 123)
(e9 10548.1 #true 124)
(f9 11175.3 #true 125)
(fs9 11839.8 #true 126)
(g9 12543.9 #true 127)
(gs9 13289.8 #false 127)
(a9 14080.0 #false 127)
(as9 14917.2 #false 127)
(b9 15804.3 #false 127)
(c10 16744.0 #false 127)
(cs10 17739.7 #false 127)
(d10 18794.5 #false 127)
(ds10 19912.1 #false 127)
(e10 21096.2 #false 127)
(f10 22350.6 #false 127)
(fs10 23679.6 #false 127)
(g10 25087.7 #false 127)
(gs10 26579.5 #false 127)
(a10 28160.0 #false 127)
(as10 29834.5 #false 127)
(b10 31608.5 #false 127))))
(values (make-immutable-hasheq (map (lambda (note)
(apply (lambda (cmn freq sci-ok? sci-number)
(cons cmn sci-number))
note))
notes))
(map (lambda (note)
(apply (lambda (cmn freq sci-ok? sci-number)
(cons freq sci-number))
note))
notes))))
(define (%symbol->roomba-note-number-or-false sym)
(if (eq? 'rest sym)
0
(hash-ref %symbol-to-roomba-note-number-hash
sym
#f)))
(module+ test
(test (%symbol->roomba-note-number-or-false 'c0) 31)
(test (%symbol->roomba-note-number-or-false 'gs1) 32)
(test (%symbol->roomba-note-number-or-false 'a4) 69)
(test (%symbol->roomba-note-number-or-false 'fs9) 126)
(test (%symbol->roomba-note-number-or-false 'b10) 127)
(test (%symbol->roomba-note-number-or-false 'xxx) #f))
(define (%frequency->roomba-note-number freq)
(let ((freq (exact->inexact freq)))
(if (zero? freq)
0
(let loop ((alist %frequency-to-roomba-note-number-alist)
(best-number #f)
(best-diff +inf.0))
(if (null? alist)
best-number
(let*-values (((this-pair) (car alist))
((this-freq) (car this-pair))
((this-diff) (abs (- this-freq freq)))
((best-number best-diff) (if (< this-diff best-diff)
(values (cdr this-pair) this-diff)
(values best-number best-diff))))
(if (= this-freq freq)
best-number
(loop (cdr alist)
best-number
best-diff))))))))
(module+ test
(test (%frequency->roomba-note-number 0 ) 0)
(test (%frequency->roomba-note-number 1 ) 31)
(test (%frequency->roomba-note-number 48 ) 31)
(test (%frequency->roomba-note-number 48.0) 31)
(test (%frequency->roomba-note-number 49 ) 31)
(test (%frequency->roomba-note-number 49.0) 31)
(test (%frequency->roomba-note-number 50 ) 31)
(test (%frequency->roomba-note-number 50.0) 31)
(test (%frequency->roomba-note-number 51 ) 32)
(test (%frequency->roomba-note-number 51.0) 32)
(test (%frequency->roomba-note-number 52 ) 32)
(test (%frequency->roomba-note-number 52.0) 32)
(test (%frequency->roomba-note-number 55 ) 33)
(test (%frequency->roomba-note-number 55.0) 33)
(test (%frequency->roomba-note-number 56 ) 33)
(test (%frequency->roomba-note-number 56.0) 33)
(test (%frequency->roomba-note-number 11839.8) 126)
(test (%frequency->roomba-note-number 11839.9) 126)
(test (%frequency->roomba-note-number 12543.8) 127)
(test (%frequency->roomba-note-number 12543.9) 127)
(test (%frequency->roomba-note-number 12544.0) 127))
(define (%roomba-song-language-note-duration->second64ths-or-false
#:second64ths-per-whole second64ths-per-whole
#:duration duration)
(let ((duration (case duration
((whole w) (truncate second64ths-per-whole))
((half h) (truncate (* 1/2 second64ths-per-whole)))
((quarter q) (truncate (* 1/4 second64ths-per-whole)))
(else duration))))
(if (and (integer? duration)
(<= 0 duration 255))
(if (exact? duration)
duration
(exact->inexact duration))
#false)))
(define (%compile-roomba-song-language-as-data-byte-list
#:error-name error-name
#:song-language song-language)
(values (length song-language)
(let loop ((data song-language))
(if (null? data)
'()
(let*-values (((note)
(car data))
((freq dur)
(match note
((list freq dur) (values freq dur))
(freq (values freq 'quarter))
(_ (error error-name
"invalid note ~S in song language ~S"
note
song-language))))
((num) (cond ((integer? freq)
(%frequency->roomba-note-number freq))
((symbol? freq)
(or (%symbol->roomba-note-number-or-false (case freq
((a) 'a4)
((b) 'b4)
((c) 'c4)
((d) 'd4)
((e) 'e4)
((f) 'f4)
((g) 'g4)
(else freq)))
(error error-name
"invalid note name in note ~S in song language ~S"
note
song-language)))
(else (error error-name
"invalid frequency in note ~S in song language ~S"
note
song-language))))
((dur) (or (%roomba-song-language-note-duration->second64ths-or-false
#:second64ths-per-whole 64 #:duration dur)
(error error-name
"invalid duration in note ~S in song language ~S"
note
song-language))))
`(,num ,dur ,@(loop (cdr data))))))))
(define (%compile-roomba-song-language-as-sci-message-bytes
#:error-name (error-name '%compile-roomba-song-language-as-sci-message-bytes)
#:song-number song-number
#:song-language song-language)
(let-values (((song-length song-byte-list)
(%compile-roomba-song-language-as-data-byte-list
#:error-name error-name
#:song-language song-language)))
(if (<= 1 song-length 16)
(apply bytes
140
song-number
song-length
song-byte-list)
(error error-name
"invalid song length ~S for song ~S"
song-length
song-language))))
(module+ test
(test (%compile-roomba-song-language-as-sci-message-bytes
#:song-number 0
#:song-language '(b a g a b b (b h) a a (a h) b d (d h)))
(let ((d 62)
(g 67)
(a 69)
(b 71)
(h 32)
(q 16))
(bytes 140 0 13 b q a q g q a q b q b q b h a q a q a h b q d q d h)))
)
(define (%compiled-roomba-song-struct-write-proc compiled-roomba-song port write?)
(fprintf port
"#<compiled-roomba-song ~S>"
(compiled-roomba-song-struct-song-language compiled-roomba-song)))
(doc (defproc (compiled-roomba-song? (x any/c))
boolean?
(para "Predicate for the compiled roomba song as produced by "
(racket compile-roomba-song)
".")))
(provide (rename-out (compiled-roomba-song-struct? compiled-roomba-song?)))
(define-struct compiled-roomba-song-struct
(song-language
roomba
song-number
sci-message-bytes)
#:methods
gen:custom-write ((define write-proc %compiled-roomba-song-struct-write-proc)))
(doc (defproc (compile-roomba-song (#:roomba roomba roomba? (current-roomba))
(#:song-number song-number roomba-song-number? 0)
(#:song-language song-language roomba-song-language?))
roomba-song?
(para "Compiles a song in the "
(tech "song language")
" to a form that is more time-efficient to store with "
(racket store-song-on-roomba)
". This may be useful for breaking up a long song into fragments
that are stored during playback.")
(para "Note that such a compiled song has the song number compiled into it.")))
(provide compile-roomba-song)
(define (compile-roomba-song #:roomba (roomba (current-roomba))
#:song-number (song-number 0)
#:song-language song-language)
(log-roomba-debug "(compile-roomba-song #:roomba ~S #:song-number ~S #:song-language ~S)"
roomba
song-number
song-language)
(make-compiled-roomba-song-struct song-language
roomba
song-number
(%compile-roomba-song-language-as-sci-message-bytes
#:error-name 'compile-roomba-song
#:song-number song-number
#:song-language song-language)))
(doc (defproc (store-song-on-roomba (#:roomba roomba roomba? (current-roomba))
(#:song-number song-number roomba-song-number? 0)
(#:song song (or/c roomba-song-language? compiled-roomba-song?)))
void?
(para "Stores a song on the Roomba in a song number slot, to be played
later using "
(racket play-song-on-roomba)
". It replaces any song previously stored at that song number on
the Roomba.")
(para "The longest song that can be stored in in a song number slot at a
time is 16 notes. However, longer songs can be played by fragmenting among
multiple slots, and/or storing fragments as they are needed during
playback.")))
(provide store-song-on-roomba)
(define (store-song-on-roomba #:roomba (roomba (current-roomba))
#:song-number (song-number 0)
#:song song)
(log-roomba-debug "(store-song-on-roomba #:roomba ~S #:song-number ~S #:song ~S)"
roomba
song-number
song)
(%assert-roomba-mode 'store-song-on-roomba roomba '(safe full))
(%send-byte-string-to-roomba roomba
(if (compiled-roomba-song-struct? song)
(compiled-roomba-song-struct-sci-message-bytes song)
(%compile-roomba-song-language-as-sci-message-bytes
#:error-name 'store-song-on-roomba
#:song-number song-number
#:song-language song))))
(doc (defproc (play-song-on-roomba (#:roomba roomba roomba? (current-roomba))
(#:song-number number roomba-song-number? 0))
void?
(para "Plays song number "
(racket number)
" as stored using "
(racket store-song-on-roomba)
".")
(para "Note that, in the current version of this package, "
(racket song-number)
" must agree with the song number under which the song was compiled.")))
(provide play-song-on-roomba)
(define (play-song-on-roomba #:roomba (roomba (current-roomba))
#:song-number (song-number 0))
(log-roomba-debug "(play-song-on-roomba #:roomba ~S #:song-number ~S)" roomba song-number)
(%assert-roomba-mode 'play-song-on-roomba roomba '(safe full))
(%send-byte-string-to-roomba roomba
(bytes 141
(%roomba-arg-song-number 'play-song-on-roomba 'song-number song-number))))
(doc (section "Sensors"))
(doc (defproc (read-roomba-sensors (#:roomba roomba roomba? (current-roomba))
(#:packet-code packet-code (or/c 0 1 2 3) 0))
(listof (cons/c symbol? any/c))
(para "Get sensor values for a packet code as an association list.")
(para "This will be documented better as soon as we add support for the
new sensors protocol in ROI and COI. Currently, it only supports SCI requests.
In the interim, the below examples, evaluated in a "
(racket with-roomba)
" context, might be illustrative:")
(racketinput (read-roomba-sensors #:packet-code 1))
(racketresultblock ((dirt-detect-right . 0)
(dirt-detect-left . 0)
(side-brush-overcurrent? . #f)
(vacuum-overcurrent? . #f)
(main-brush-overcurrent? . #f)
(drive-right-overcurrent? . #f)
(drive-left-overcurrent? . #f)
(virtual-wall? . #f)
(cliff-right? . #f)
(cliff-front-right? . #f)
(cliff-front-left? . #f)
(cliff-left? . #f)
(wall? . #f)
(bump-right? . #f)
(bump-left? . #f)
(wheeldrop-right? . #f)
(wheeldrop-left? . #f)
(wheeldrop-caster? . #f)))
(racketinput (read-roomba-sensors #:packet-code 2))
(racketresultblock ((angle . 0)
(distance . 0)
(max-button? . #f)
(clean-button? . #f)
(spot-button? . #f)
(power-button? . #f)
(remote-control-command . 255)))
(racketinput (read-roomba-sensors #:packet-code 3))
(racketresultblock ((battery-capacity . 973)
(battery-charge . 889)
(battery-temperature . 30)
(battery-current . -176)
(battery-voltage . 13888)
(battery-charging-state . not-charging)))))
(provide read-roomba-sensors)
(define (read-roomba-sensors #:roomba (roomba (current-roomba))
#:packet-code (packet-code 0))
(log-roomba-debug "(roomba-sensors #:roomba ~S #:packet-code ~S)" roomba packet-code)
(%assert-roomba-mode 'roomba-sensors roomba '(passive safe full))
(let ((packet-code (%roomba-args-one 'roomba-sensors 'packet-code packet-code '(0 1 2 3))))
(%send-byte-string-to-roomba roomba
(bytes 142 packet-code))
(let*-values (((read-size decoder-proc)
(case packet-code
((0) (values 26 %decode-roomba-sensor-packet-0))
((1) (values 10 %decode-roomba-sensor-packet-1))
((2) (values 6 %decode-roomba-sensor-packet-2))
((3) (values 10 %decode-roomba-sensor-packet-3))
(else (error 'roomba-sensors
"invalid packet-code ~S"
packet-code))))
((bstr) (%read-byte-string-from-roomba roomba read-size)))
(log-roomba-debug "roomba-sensors: read ~S" bstr)
(decoder-proc bstr 0 '()))))
(define (%roomba:signed-byte->integer byt)
(if (byte? byt)
(if (< byt 128)
byt
(- (+ (bitwise-xor (bitwise-and #b01111111 byt)
#b01111111)
1)))
(raise-type-error '%roomba:signed-byte->integer
"byte?"
0
byt)))
(module+ test
(test (%roomba:signed-byte->integer #b01111111) +127)
(test (%roomba:signed-byte->integer #b01111110) +126)
(test (%roomba:signed-byte->integer #b01111101) +125)
(test (%roomba:signed-byte->integer #b00000001) +1)
(test (%roomba:signed-byte->integer #b00000000) 0)
(test (%roomba:signed-byte->integer #b11111111) -1)
(test (%roomba:signed-byte->integer #b10000010) -126)
(test (%roomba:signed-byte->integer #b10000001) -127)
(test (%roomba:signed-byte->integer #b10000000) -128))
(define (%decode-bumps-and-wheeldrops-roomba-sensor bstr offset alist)
(let ((byt (bytes-ref bstr offset)))
`((bump-right? . ,(bitwise-bit-set? byt 0))
(bump-left? . ,(bitwise-bit-set? byt 1))
(wheeldrop-right? . ,(bitwise-bit-set? byt 2))
(wheeldrop-left? . ,(bitwise-bit-set? byt 3))
(wheeldrop-caster? . ,(bitwise-bit-set? byt 4))
,@alist)))
(define (%decode-wall-roomba-sensor bstr offset alist)
`((wall? . ,(bitwise-bit-set? (bytes-ref bstr offset) 0))
,@alist))
(define (%decode-cliff-left-roomba-sensor bstr offset alist)
`((cliff-left? . ,(bitwise-bit-set? (bytes-ref bstr offset) 0))
,@alist))
(define (%decode-cliff-front-left-roomba-sensor bstr offset alist)
`((cliff-front-left? . ,(bitwise-bit-set? (bytes-ref bstr offset) 0))
,@alist))
(define (%decode-cliff-front-right-roomba-sensor bstr offset alist)
`((cliff-front-right? . ,(bitwise-bit-set? (bytes-ref bstr offset) 0))
,@alist))
(define (%decode-cliff-right-roomba-sensor bstr offset alist)
`((cliff-right? . ,(bitwise-bit-set? (bytes-ref bstr offset) 0))
,@alist))
(define (%decode-virtual-wall-roomba-sensor bstr offset alist)
`((virtual-wall? . ,(bitwise-bit-set? (bytes-ref bstr offset) 0))
,@alist))
(define (%decode-motor-overcurrents-roomba-sensor bstr offset alist)
(let ((byt (bytes-ref bstr offset)))
`((side-brush-overcurrent? . ,(bitwise-bit-set? byt 0))
(vacuum-overcurrent? . ,(bitwise-bit-set? byt 1))
(main-brush-overcurrent? . ,(bitwise-bit-set? byt 2))
(drive-right-overcurrent? . ,(bitwise-bit-set? byt 3))
(drive-left-overcurrent? . ,(bitwise-bit-set? byt 4))
,@alist)))
(define (%decode-dirt-detect-left-roomba-sensor bstr offset alist)
`((dirt-detect-left . ,(bytes-ref bstr offset))
,@alist))
(define (%decode-dirt-detect-right-roomba-sensor bstr offset alist)
`((dirt-detect-right . ,(bytes-ref bstr offset))
,@alist))
(define (%decode-remote-control-command-roomba-sensor bstr offset alist)
`((remote-control-command . ,(bytes-ref bstr offset))
,@alist))
(define (%decode-buttons-roomba-sensor bstr offset alist)
(let ((byt (bytes-ref bstr offset)))
`((max-button? . ,(bitwise-bit-set? byt 0))
(clean-button? . ,(bitwise-bit-set? byt 1))
(spot-button? . ,(bitwise-bit-set? byt 2))
(power-button? . ,(bitwise-bit-set? byt 3))
,@alist)))
(define (%decode-distance-roomba-sensor bstr offset alist)
`((distance . ,(integer-bytes->integer bstr
#true
#true
offset
(+ 2 offset)))
,@alist))
(define (%decode-angle-roomba-sensor bstr offset alist)
`((angle . ,(integer-bytes->integer bstr
#true
#true
offset
(+ 2 offset)))
,@alist))
(define (%decode-battery-charging-state-roomba-sensor bstr offset alist)
`((battery-charging-state . ,(case (bytes-ref bstr offset)
((0) 'not-charging)
((1) 'charging-recovery)
((2) 'charging)
((3) 'trickle-charging)
((4) 'waiting)
((5) 'charging-error)
(else #f)))
,@alist))
(define (%decode-battery-voltage-roomba-sensor bstr offset alist)
`((battery-voltage . ,(integer-bytes->integer bstr
#false
#true
offset
(+ 2 offset)))
,@alist))
(define (%decode-battery-current-roomba-sensor bstr offset alist)
`((battery-current . ,(integer-bytes->integer bstr
#true
#true
offset
(+ 2 offset)))
,@alist))
(define (%decode-battery-temperature-roomba-sensor bstr offset alist)
`((battery-temperature . ,(%roomba:signed-byte->integer (bytes-ref bstr offset)))
,@alist))
(define (%decode-battery-charge-roomba-sensor bstr offset alist)
`((battery-charge . ,(integer-bytes->integer bstr
#false
#true
offset
(+ 2 offset)))
,@alist))
(define (%decode-battery-capacity-roomba-sensor bstr offset alist)
`((battery-capacity . ,(integer-bytes->integer bstr
#false
#true
offset
(+ 2 offset)))
,@alist))
(define (%decode-roomba-sensor-packet-0 bstr offset alist)
(let* ((alist (%decode-roomba-sensor-packet-1 bstr offset alist))
(alist (%decode-roomba-sensor-packet-2 bstr (+ 10 offset) alist))
(alist (%decode-roomba-sensor-packet-3 bstr (+ 16 offset) alist)))
alist))
(define (%decode-roomba-sensor-packet-1 bstr offset alist)
(let* ((alist (%decode-bumps-and-wheeldrops-roomba-sensor bstr offset alist))
(alist (%decode-wall-roomba-sensor bstr (+ 1 offset) alist))
(alist (%decode-cliff-left-roomba-sensor bstr (+ 2 offset) alist))
(alist (%decode-cliff-front-left-roomba-sensor bstr (+ 3 offset) alist))
(alist (%decode-cliff-front-right-roomba-sensor bstr (+ 4 offset) alist))
(alist (%decode-cliff-right-roomba-sensor bstr (+ 5 offset) alist))
(alist (%decode-virtual-wall-roomba-sensor bstr (+ 6 offset) alist))
(alist (%decode-motor-overcurrents-roomba-sensor bstr (+ 7 offset) alist))
(alist (%decode-dirt-detect-left-roomba-sensor bstr (+ 8 offset) alist))
(alist (%decode-dirt-detect-right-roomba-sensor bstr (+ 9 offset) alist)))
alist))
(define (%decode-roomba-sensor-packet-2 bstr offset alist)
(let* ((alist (%decode-remote-control-command-roomba-sensor bstr offset alist))
(alist (%decode-buttons-roomba-sensor bstr (+ 1 offset) alist))
(alist (%decode-distance-roomba-sensor bstr (+ 2 offset) alist))
(alist (%decode-angle-roomba-sensor bstr (+ 4 offset) alist)))
alist))
(define (%decode-roomba-sensor-packet-3 bstr offset alist)
(let* ((alist (%decode-battery-charging-state-roomba-sensor bstr offset alist))
(alist (%decode-battery-voltage-roomba-sensor bstr (+ 1 offset) alist))
(alist (%decode-battery-current-roomba-sensor bstr (+ 3 offset) alist))
(alist (%decode-battery-temperature-roomba-sensor bstr (+ 5 offset) alist))
(alist (%decode-battery-charge-roomba-sensor bstr (+ 6 offset) alist))
(alist (%decode-battery-capacity-roomba-sensor bstr (+ 8 offset) alist)))
alist))
(doc (section "Troubleshooting")
(para "Here are a few troubleshooting tips.")
(para "First things first:")
(itemlist #:style 'ordered
(item "Ensure that the serial cable or other interface is firmly
attached in all places it could become loose.")
(item "If you built a serial interface using instructions found
on the Web, be aware that some pinout diagrams for the mini-DIN were published
with pins reversed. Double-check against different pinouts.")
(item "If you're connecting to an iRobot Create using the
Command Module, make sure that you follow the boot-time procedures documentd in
the "
(hyperlink "http://www.irobot.com/filelibrary/pdfs/hrd/create/Command%20Module%20Manual_v2.pdf"
(italic "iRobot Command Module Owners Manual"))
". Also note that the developers of this package have
not yet tested use through the Command Module."))
(para "If the PC's serial port or other interface on the PC side is not
working:")
(itemlist #:style 'ordered
(item "Consider whether you have the right device file for your "
(racket #:device)
" argument. For example, if you're using "
(racket "/dev/ttyS0")
", maybe the correct device is "
(racket "/dev/ttyS1")
", "
(racket "/dev/ttyUSB0")
", or something else.")
(item "If you're using a USB interface on the PC side, perhaps
using a USB-to-RS232 adapter with an iRobot RS232-to-Roomba cable, check
whether the USB device is actually recognized by the PC. On GNU/Linux, you can
use the "
(tt "lsusb")
" shell command to list recognized USB devices, and you
can also check the "
(tt "syslog")
" log files for the time that you plugged in the device.")
(item "If the PC's serial port is an RS232 port on a laptop
dock, consider that a hardware or operating system bug might be causing the
serial port to ``disappeared''. This has been known to happen with a ThinkPad
T60 plugged into a dock, for example, and the solution in that case is to
reboot the laptop while plugged into the dock."))
(para "If the PC's serial port or other interface on the PC side seems OK,
but the Roomba is still not communicating:")
(itemlist #:style 'ordered
(item "On at least some Roomba models (including the 400), the
Clean or Power button should be solid green before the Roomba can be accessed
via this package. If button is not solid green, try pressing it, in hopes of
it turning solid green. Be prepared to lift up the Roomba if pressing the
button starts a clean cycle.")
(item "If the Roomba's Clean or Power button is not solid green
and pressing does not correct that, try removing and reattaching the cable from
the Roomba's serial port.")
(item "If all else fails, try removing the cable from the
Roomba's mini-DIN, removing the Roomba's battery, waiting a few seconds,
reattaching the Roomba's battery, and finally reattaching the cable to the
Roomba's mini-DIN.")
(item "Consider that the Roomba is refusing to communicate
because its battery desperately needs charging, even if it appears to have some
charge left."))
(para "Please contact the author of this package with additional tips that
should be mentioned here."))
(doc (section "Known Issues")
(itemlist
(item "Needs initial testing, with different models.")
(item "Figure out why DrRacket is prompting for input in the Interactions
pane under some unclear circumstances.")
(item "Continue working on the ROI and COI protocols, once appropriate
test hardware is available.")
(item "In process of adding ROI and COI extensions for sensors, document
it. Currently our sensors documentation is almost nonexistent.")
(item "Test use of USB interface of Create Command Module, once we have a
working one.")
(item "Improve how stdio error messages are handled when calling "
(tt "/bin/stty")
".")
(item "We might be able to do better waking of the Roomba, using RTS.
However, we cannot test this at this time, since, on our test setup at the
moment (Roomba 400, plugged into iRobot brand cable, plugged into RS232 port of
ThinkPad dock), even example code does not wake the Roomba.")
(item "Any any special support needed for other off-the-shelf Roomba
hardware interfaces, such as those by RoboDynamics. We are aware that some of
them are reported to need special handling, but we do not presently have use of
them for testing.")
(item "A "
(racket let-roomba-sensors)
" would be nice, so you could do things like this efficiently on
SCI (OI makes it easier):"
(racketblock (let-roomba-sensors (wall battery-charge distance angle)
...))
"We have an example but have not coded it yet, til we look more
closely at the different OI specs. Until then, we expect that the form would
expand to code that looked at the protocol at runtime, and did different
optimizations for SCI, OI-500 and OI-Create.")
(item "Support a little bit more of Common Music Notation, especially for
meter.")
(item "Add convenience for compiling and playing songs longer than 16
notes.")
(item "Test on Mac OS X.")
(item "Possibly add support for Microsoft Windows. Especially if Windows
7 and later have filesystem path devices for serial ports.")
(item "Get rid of LED control overlap in "
(racket set-roomba-leds)
".")
(item "Put Raspberry Pi with WiFi onboard an iRobot Create. Hook up
development tools so that Roomba programs can run onboard, on the Pi, as well
as offboard on PC (say, in DrRacket for debugging), with the Pi gatewaying the
OI protocol received over SSH WiFi.")))
(doc history
(#:planet 1:0 #:date "2013-08-18"
(itemlist
(item "Initial release. Still needs some initial testing with
various different Roombas, and we are releasing now for that purposes."))))
![[logo]](/logo.png){kind=logo}