Help Haskell driving Medical Instruments
Recently, I received as gift medical instruments designed by one of my father former students. There is a description of these instruments on my web page. Here is the address: http://www.discenda.org/med/ By the way, I am not that guy that appears in a picture wearing emg sensors. That said, the instruments and everything else are programmed in Clean. Then I have a new opportunity of translating Clean programs to Haskell and test them in a real application application. Of course, I simplified the programs to see how they work. The medical instruments have on-board computers, that record signals (electromyograms, electroencephalograms, electrocardiograms, end-tydal CO2 partial pressure and temperature), pre-process them and send them to the main computer. The main-computer recognizes patterns in the signals, and use the result to drive a wheelchair, or to call a doctor. On my page you wil find more complete explanations and pictures of the instruments. For ready reference, here is my address: http://www.discenda.org/med/ I decided start my translation work from the most simple programs, the graphical interface and the communication protocol. After substituting a Haskell program for the Clean original, I discovered that the system did not work anymore if I exited the Haskell program. In few words, after leaving the Haskell program without turning off the computer or the sensors, and entering the Haskell program again, Haskell failed to communicate with the sensors. I did what I always do in such a situation: I simplified the program until I reduced it to a few lines. I discovered that Haskell failed to close the serial port. There is a serial to UART-0 driver that allows me to plug the serial cable to a USB port, that both feeds the sensors, and permit communication. I fixed the bug by passing a useless integer argument to the function used to close the port. Since I don't like this kind of patch (useless arguments), I would like to know why the original program does not work, and also I would appreciate if someone could suggest a way to get rid of the argument whose sole job is force Haskell to close the port. The GUI is based on the Small JAPI biding, fixed and incremented with text processing components. Here is the fixed Haskell program: import Gui.Binding import Gui.Types import Gui.Constants import SER.IAL import Control.Monad import Data.Char main = do rv <- j_start frame <- j_frame "Sensors" exit_button <- j_button frame "Exit" j_setpos exit_button 50 50 j_setsize exit_button 80 30 fld <- j_textfield frame 30 j_setpos fld 50 100 j_show frame opencport(4) waitForFrameAction frame fld exit_button let r = closecport 7 {- without the argument, closecport does not work -} print r return j_quit waitForFrameAction :: Frame -> Object -> Object -> IO Bool waitForFrameAction frame f b = do obj <- j_nextaction again <- if obj == event b then return False else do {- nm <- j_gettext f 200 -} tx <- sendMessage 1 "t" let tp= filter (> ' ') tx rx <- sendMessage 1 "x" let rd= filter (> ' ') rx let x = hex2dec rd let tt= (fromIntegral x)*209.0/1024 - 67.5 j_settext f ((show tt)++" ==> "++tp) return True if not again then return True else waitForFrameAction frame f b hex2dec :: String -> Int hex2dec h= sum (zipWith (*) (map (16^) [3,2,1,0]) [digitToInt c | c <- h]) convert d r s0= (fromIntegral (hex2dec d))*r/1024.0- s0 As I told before, let r = closecport 7 did not work until I gave it an argument. Here is the interface between the C-side, and the Haskell-side of the program: {-# LANGUAGE ForeignFunctionInterface #-} module SER.IAL where import Control.Monad import Foreign import Foreign.C.Types import Foreign.C foreign import ccall "rs232.h opencport" opencport :: CInt -> IO () foreign import ccall "rs232.h closecport" closecport :: CInt -> CInt foreign import ccall "rs232.h rdrs232" c_sendmsg :: CInt -> CString -> CString sendMessage :: Int -> String -> IO String sendMessage n msg = withCString msg $ \str -> peekCString (c_sendmsg (fromIntegral n) str) Originally, I had the following line (that did not work properly): foreign import ccall "rs232.h closecport" closecport :: IO () You will find below the C-program. The original program (that did not work) had the following definition for closecport: int closecport() { CloseComport(); return 3; } This deffinition (that did not work) was replaced by the following one: int closecport(int n) { CloseComport(); return n; } Here is the complete C program: #include "serial.h" #include <string.h> #include <stdio.h> /* Possible baudrates on a normal pc: 50, 75, 110, 134, 150, 200, 300, 600, 1200, 1800, 2400, 4800, 9600, 19200, 38400, 57600, 115200 */ #define BAUD "baud=9600 data=8 parity=N stop=1" HANDLE Cport; char comports[16][10]={"\\\\.\\COM1", "\\\\.\\COM2", "\\\\.\\COM3", "\\\\.\\COM4", "\\\\.\\COM5", "\\\\.\\COM6", "\\\\.\\COM7", "\\\\.\\COM8", "\\\\.\\COM9", "\\\\.\\COM10", "\\\\.\\COM11", "\\\\.\\COM12", "\\\\.\\COM13", "\\\\.\\COM14", "\\\\.\\COM15", "\\\\.\\COM16"}; int OpenComport(int comport_number) { if(comport_number>15) { printf("illegal comport number\n"); return(1); } Cport = CreateFileA(comports[comport_number], GENERIC_READ|GENERIC_WRITE, 0, /* no share */ NULL, /* no security */ OPEN_EXISTING, 0, /* no threads */ NULL); /* no templates */ if(Cport==INVALID_HANDLE_VALUE) { printf("unable to open comport\n"); return(1); } DCB port_settings; memset(&port_settings, 0, sizeof(port_settings)); /* clear the new struct */ port_settings.DCBlength = sizeof(port_settings); if(!BuildCommDCBA(BAUD, &port_settings)) { printf("unable to set comport dcb settings\n"); CloseHandle(Cport); return(1); } if(!SetCommState(Cport, &port_settings)) { printf("unable to set comport cfg settings\n"); CloseHandle(Cport); return(1); } COMMTIMEOUTS Cptimeouts; Cptimeouts.ReadIntervalTimeout = MAXDWORD; Cptimeouts.ReadTotalTimeoutMultiplier = 10; Cptimeouts.ReadTotalTimeoutConstant = 10; Cptimeouts.WriteTotalTimeoutMultiplier = 10; Cptimeouts.WriteTotalTimeoutConstant = 10; if(!SetCommTimeouts(Cport, &Cptimeouts)) { printf("unable to set comport time-out settings\n"); CloseHandle(Cport); return(1); } return(0); } int PollComport(unsigned char *buf, int size) { int n; if(size>4096) size = 4096; /* added the void pointer cast, otherwise gcc will complain about */ /* "warning: dereferencing type-punned pointer will break strict aliasing rules" */ ReadFile(Cport, buf, size, (LPDWORD)((void *)&n), NULL); return(n); } int RdByte(unsigned char* m) { int n; ReadFile(Cport, m, 1, (LPDWORD)((void *)&n), NULL); return(n); } int SendByte(unsigned char byte) { int n; WriteFile(Cport, &byte, 1, (LPDWORD)((void *)&n), NULL); if(n<0) return(1); return(0); } int SendBuf(unsigned char *buf, int size) { int n; if(WriteFile(Cport, buf, size, (LPDWORD)((void *)&n), NULL)) { return(n); } return(-1); } int CloseComport(void) { CloseHandle(Cport); return(0); } int IsCTSEnabled(void) { int status; GetCommModemStatus(Cport, (LPDWORD)((void *)&status)); if(status&MS_CTS_ON) return(1); else return(0); } int cprintf(const char *text) /* sends a string to serial port */ { while(*text != 0) SendByte(*(text++)); return(0); } int opencport(int p) { OpenComport(p-1); return 3; } int closecport(int n) { CloseComport(); return n; } char* rdrs232(int n, char* msg) { char *str; char mm; int i, j; for (j=0; j<n; j++) { SendByte(msg[j]); } str = (char *) malloc(16000); i=0; mm=0; while (mm != 10) { RdByte(&mm); str[i]= mm; i= i+1; } if (i>0 && str[0]==0) { str[0]= ' ';} return(str); } Finally, here is the serial.h file: #ifndef rs232_INCLUDED #define rs232_INCLUDED #ifdef __cplusplus extern "C" { #endif #include <stdio.h> #include <string.h> #ifdef __linux__ #include <termios.h> #include <sys/ioctl.h> #include <unistd.h> #include <fcntl.h> #include <sys/types.h> #include <sys/stat.h> #include <limits.h> #else #include <windows.h> #endif int OpenComport(int); int PollComport(unsigned char *, int); int SendByte(unsigned char); int SendBuf(unsigned char *, int); int CloseComport(void); int cprintf(const char *); int IsCTSEnabled(void); char *topa(int n); int opencport(int p); int closecport(int n); char* rdrs232(int n, char* msg); #ifdef __cplusplus } /* extern "C" */ #endif #endif __________________________________________________________________ Make your browsing faster, safer, and easier with the new Internet Explorer® 8. Optimized for Yahoo! Get it Now for Free! at http://downloads.yahoo.com/ca/internetexplorer/
Does marking the call `unsafe` make any difference? This is running on a *NIX of some flavour? -- Jason Dusek
Hi, Jason. I don't know how to mark the call unsafe. And I don't know what is a *Nix (perhaps unix?). I am running the main program on Windows. Here is the compilation script: ghc -fglasgow-exts serial.c %1.hs -L./ -ljapi --make erase *.hi erase *.o strip %1.exe BTW I figure out that passing an argument to closecport only makes the problem occur less often. Here is an example: D:\ghc\sensors>strip temper.exe D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe 4 D:\ghc\sensors>temper.exe unable to set comport cfg settings 4 --- On Mon, 11/9/09, Jason Dusek <jason.dusek@gmail.com> wrote: From: Jason Dusek <jason.dusek@gmail.com> Subject: Re: [Haskell-cafe] Help Haskell driving Medical Instruments To: "Philippos Apolinarius" <phi500ac@yahoo.ca> Cc: "Haskell Cafe" <haskell-cafe@haskell.org> Received: Monday, November 9, 2009, 11:41 PM Does marking the call `unsafe` make any difference? This is running on a *NIX of some flavour? -- Jason Dusek __________________________________________________________________ Looking for the perfect gift? Give the gift of Flickr! http://www.flickr.com/gift/
Am Dienstag 10 November 2009 14:01:33 schrieb Philippos Apolinarius:
Hi, Jason. I don't know how to mark the call unsafe. And I don't know what is a *Nix (perhaps unix?).
Unix or unix-derivate (linux, BSD, ...)
I am running the main program on Windows.
Then it might be necesary to let the foreign calls have the calling convention stdcall instead of ccall.
2009/11/10 Philippos Apolinarius <phi500ac@yahoo.ca>
I don't know how to mark the call unsafe. [...] I am running the main program on Windows.
Marking it unsafe is done by putting "unsafe" in the foreign import declaration. Even if it turns out not to fix the problem, it reduces the overhead of foreign calls (and is safe as long as they aren't going to call back into Haskell). Because your on Windows, you want to use "stdcall", as mentioned by Daniel Fischer. Thus the full declaration is: foreign import stdcall unsafe "rs232.h closecport" closecport :: IO () Let us know if this helps.
Here is the compilation script:
ghc -fglasgow-exts serial.c %1.hs -L./ -ljapi --make erase *.hi erase *.o strip %1.exe
I encourage you to look into Cabal soon :) -- Jason Dusek
Hi, Jason. Thank you for your explanations. They were very useful. In the light of what you said, I modified the programs as shown below (commented lines failed to work). Forcing the C function to return a number, wrapping the returned number in IO, and printing the number, I succeeded in bringing falures down to 1 case in 20 trials (average). By the way, I talked to doctors who work with capnograms, and they said that all Windows or Linux machines have problems in closing communication ports. However, it seems that capnographs are not turned off very often. I mean, when the doctor move the capnograph from one patient to another, s/he turns off the instrument. Therefore, this behavior does not create problems. However, what bothers me is that Clean always succeds in closeing the port. {-# LANGUAGE ForeignFunctionInterface #-} {- file: SER/IAL.hs -} module SER.IAL where import Control.Monad import Foreign import Foreign.C.Types import Foreign.C foreign import ccall "rs232.h opencport" opencport :: CInt -> IO () -- foreign import ccall "rs232.h closecport" closecport :: CInt -> CInt -- foreign import stdcall unsafe "rs232.h closecport" closecport :: IO () -- foreign import ccall unsafe "rs232.h closecport" c_closecport :: CInt foreign import ccall unsafe "rs232.h closecport" c_closecport :: CInt -> CInt closecport :: Int -> IO Int closecport n= return (fromIntegral (c_closecport (fromIntegral n))) foreign import ccall "rs232.h rdrs232" c_sendmsg :: CInt -> CString -> CString sendMessage :: Int -> String -> IO String sendMessage n msg = withCString msg $ \str -> peekCString (c_sendmsg (fromIntegral n) str) {- file: sensors.hs -} import Gui.Binding import Gui.Types import Gui.Constants import SER.IAL import Control.Monad import Data.Char main = do rv <- j_start frame <- j_frame "Sensors" avg <- j_button frame "Sampling" j_setpos avg 20 150 j_setsize avg 90 30 rb <- j_button frame "Read" j_setpos rb 125 150 j_setsize rb 90 30 tb <- j_button frame "Acquisition" j_setpos tb 230 150 j_setsize tb 90 30 fld <- j_textfield frame 40 j_setpos fld 20 100 menubar <- j_menubar frame file <- j_menu menubar "File" quitMI <- j_menuitem file "Quit" j_show frame opencport(3) waitForFrameAction frame fld rb tb avg quitMI r <- closecport 5 putStrLn (show r) return j_quit waitForFrameAction frame f rb tb avg q = do obj <- j_nextaction again <- if obj == event q then return False else if obj == event rb then (do msg <- sendMessage 1 "r" putStrLn msg return True) else if obj == event tb then (do tx <- sendMessage 1 "t" let tp= filter (> ' ') tx j_settext f tp return True) else if obj == event avg then (do ok <- sendMessage 1 "m" val <- j_gettext f 300 ns <- sendMessage 2 val putStrLn ((filter (> ' ') ok) ++ ns) return True) else (do tx <- sendMessage 1 "t" let tp= filter (> ' ') tx rx <- sendMessage 1 "x" let rd= filter (> ' ') rx let x = hex2dec rd let tt= (fromIntegral x)*209.1/1023.0 - 67.23 j_settext f ((show tt)++" ==> "++tp) return True) if not again then return True else waitForFrameAction frame f rb tb avg q hex2dec :: String -> Int hex2dec h= sum (zipWith (*) (map (16^) [3,2,1,0]) [digitToInt c | c <- h]) convert d r s0= (fromIntegral (hex2dec d))*r/1024.0- s0 {- 1a43 67.23; 082b - 209.1 -} // file: serial.c #include "serial.h" #include <string.h> #include <stdio.h> /* Possible baudrates on a normal pc: 50, 75, 110, 134, 150, 200, 300, 600, 1200, 1800, 2400, 4800, 9600, 19200, 38400, 57600, 115200 */ #define BAUD "baud=9600 data=8 parity=N stop=1" HANDLE Cport; char comports[16][10]={"\\\\.\\COM1", "\\\\.\\COM2", "\\\\.\\COM3", "\\\\.\\COM4", "\\\\.\\COM5", "\\\\.\\COM6", "\\\\.\\COM7", "\\\\.\\COM8", "\\\\.\\COM9", "\\\\.\\COM10", "\\\\.\\COM11", "\\\\.\\COM12", "\\\\.\\COM13", "\\\\.\\COM14", "\\\\.\\COM15", "\\\\.\\COM16"}; int OpenComport(int comport_number) { if(comport_number>15) { printf("illegal comport number\n"); return(1); } Cport = CreateFileA(comports[comport_number], GENERIC_READ|GENERIC_WRITE, 0, /* no share */ NULL, /* no security */ OPEN_EXISTING, 0, /* no threads */ NULL); /* no templates */ if(Cport==INVALID_HANDLE_VALUE) { printf("unable to open comport\n"); return(1); } DCB port_settings; memset(&port_settings, 0, sizeof(port_settings)); /* clear the new struct */ port_settings.DCBlength = sizeof(port_settings); if(!BuildCommDCBA(BAUD, &port_settings)) { printf("unable to set comport dcb settings\n"); CloseHandle(Cport); return(1); } if(!SetCommState(Cport, &port_settings)) { printf("unable to set comport cfg settings\n"); CloseHandle(Cport); return(1); } COMMTIMEOUTS Cptimeouts; Cptimeouts.ReadIntervalTimeout = MAXDWORD; Cptimeouts.ReadTotalTimeoutMultiplier = 10; Cptimeouts.ReadTotalTimeoutConstant = 10; Cptimeouts.WriteTotalTimeoutMultiplier = 10; Cptimeouts.WriteTotalTimeoutConstant = 10; if(!SetCommTimeouts(Cport, &Cptimeouts)) { printf("unable to set comport time-out settings\n"); CloseHandle(Cport); return(1); } return(0); } int PollComport(unsigned char *buf, int size) { int n; if(size>4096) size = 4096; /* added the void pointer cast, otherwise gcc will complain about */ /* "warning: dereferencing type-punned pointer will break strict aliasing rules" */ ReadFile(Cport, buf, size, (LPDWORD)((void *)&n), NULL); return(n); } int RdByte(unsigned char* m) { int n; ReadFile(Cport, m, 1, (LPDWORD)((void *)&n), NULL); return(n); } int SendByte(unsigned char byte) { int n; WriteFile(Cport, &byte, 1, (LPDWORD)((void *)&n), NULL); if(n<0) return(1); return(0); } int SendBuf(unsigned char *buf, int size) { int n; if(WriteFile(Cport, buf, size, (LPDWORD)((void *)&n), NULL)) { return(n); } return(-1); } int CloseComport(void) { CloseHandle(Cport); return(0); } int IsCTSEnabled(void) { int status; GetCommModemStatus(Cport, (LPDWORD)((void *)&status)); if(status&MS_CTS_ON) return(1); else return(0); } int cprintf(const char *text) /* sends a string to serial port */ { while(*text != 0) SendByte(*(text++)); return(0); } int opencport(int p) { OpenComport(p-1); return 3; } int closecport(int n) { CloseHandle(Cport); printf("Bye\n"); return n; } char* rdrs232(int n, char* msg) { char *str; char mm; int i, j; for (j=0; j<n; j++) { SendByte(msg[j]); } str = (char *) malloc(16000); i=0; mm=0; while (mm != 10) { RdByte(&mm); str[i]= mm; i= i+1; } if (i>0 && str[0]==0) { str[0]= ' ';} return(str); } //file: serial.h #ifndef rs232_INCLUDED #define rs232_INCLUDED #ifdef __cplusplus extern "C" { #endif #include <stdio.h> #include <string.h> #ifdef __linux__ #include <termios.h> #include <sys/ioctl.h> #include <unistd.h> #include <fcntl.h> #include <sys/types.h> #include <sys/stat.h> #include <limits.h> #else #include <windows.h> #endif int OpenComport(int); int PollComport(unsigned char *, int); int SendByte(unsigned char); int SendBuf(unsigned char *, int); int CloseComport(void); int cprintf(const char *); int IsCTSEnabled(void); char *topa(int n); int opencport(int p); int closecport(int n); char* rdrs232(int n, char* msg); #ifdef __cplusplus } /* extern "C" */ #endif #endif --- On Tue, 11/10/09, Jason Dusek <jason.dusek@gmail.com> wrote: From: Jason Dusek <jason.dusek@gmail.com> Subject: Re: [Haskell-cafe] Help Haskell driving Medical Instruments To: "Philippos Apolinarius" <phi500ac@yahoo.ca> Cc: "Haskell Cafe" <haskell-cafe@haskell.org> Received: Tuesday, November 10, 2009, 1:09 PM 2009/11/10 Philippos Apolinarius <phi500ac@yahoo.ca>
I don't know how to mark the call unsafe. [...] I am running the main program on Windows.
Marking it unsafe is done by putting "unsafe" in the foreign import declaration. Even if it turns out not to fix the problem, it reduces the overhead of foreign calls (and is safe as long as they aren't going to call back into Haskell). Because your on Windows, you want to use "stdcall", as mentioned by Daniel Fischer. Thus the full declaration is: foreign import stdcall unsafe "rs232.h closecport" closecport :: IO () Let us know if this helps.
Here is the compilation script:
ghc -fglasgow-exts serial.c %1.hs -L./ -ljapi --make erase *.hi erase *.o strip %1.exe
I encourage you to look into Cabal soon :) -- Jason Dusek __________________________________________________________________ Make your browsing faster, safer, and easier with the new Internet Explorer® 8. Optimized for Yahoo! Get it Now for Free! at http://downloads.yahoo.com/ca/internetexplorer/
On Wed, Nov 11, 2009 at 6:00 PM, Philippos Apolinarius <phi500ac@yahoo.ca> wrote:
closecport :: Int -> IO Int closecport n= return (fromIntegral (c_closecport (fromIntegral n)))
The return here doesn't do what you think it does - semantically, the value of c_closecport is still considered pure and assumed to be referentially transparent, so multiple calls to closecport are allowed to share the value returned, or delay the call until the value is unwrapped, call it multiple times for each use of the value, or anything else. You need to use IO *directly* in the foreign import declaration so that the compiler knows that the function calls can't be shared or inlined or generally messed about with: the IO tells it that order of execution with respect to your other IO actions is important. This one looks the most right: foreign import stdcall unsafe "rs232.h closecport" closecport :: IO () so I think you need to look closer about why it wasn't working for you, and where or how you were using it.
First of all, I find it striking that you are using the declaration: foreign import ccall unsafe "rs232.h closecport" c_closecport :: CInt -> CInt and that it actually works. I would think the only workable declaration would be: foreign import stdcall unsafe "rs232.h closecport" closecport :: IO () You've tried the signature with `stdcall` and `IO ()` and it doesn't work at all? Likewise, your signature for `c_sendmsg` strikes me as perilous. It should result in a value in `IO`. However, let's ignore all that for now. I wonder, does the Haskell always call `closecport`? Maybe you could put in a print statement in the C to find out? -- Jason Dusek
On Tue, Nov 10, 2009 at 5:04 AM, Philippos Apolinarius <phi500ac@yahoo.ca> wrote:
foreign import ccall "rs232.h opencport" opencport :: CInt -> IO () foreign import ccall "rs232.h closecport" closecport :: CInt -> CInt
[...]
Originally, I had the following line (that did not work properly):
foreign import ccall "rs232.h closecport" closecport :: IO ()
I don't know why the latter line didn't work properly, but I'm pretty sure it's closer to the right answer than the former. If you don't have an IO type for your function, then Haskell is allowed to assume it is pure (has no side effects) and can then call it only when the result is needed, or multiple times if it likes, without affecting the meaning of the program. For a function that closes a handle this is clearly not the case. So I'm pretty sure your type signature needs to be in IO if you want to guarantee it is called at the right time; it might be worth elaborating on how the IO () version did not work, and how you used it. The way you are using it now would appear to work most of the time because the print statement will force the result to be evaluated, forcing the function to be called - but having a handle closed based on when an apparently irrelevant print statement runs or doesn't is obviously not ideal.
participants (4)
-
Ben Millwood -
Daniel Fischer -
Jason Dusek -
Philippos Apolinarius