(require "w32.dll")

; Globals to modify

; - set *port* to some appropriate string.  if CE, we use COM1: by default, which
;   will address the serial synch cable on a H/PC

(define *port* (if *windows-ce* "COM1:" "COM2:"))

;; Timing constants, in millisecs.
;; The pulse time is generous, which greatly slows signalling,
;; but lets the Firecracker transmit successfully over greater distances.
;; You may lower the pulse to as low as "1" for point-blank operation.
;;
(define time-warmup 30)
(define time-pulse 20)


;; System calls

(define *kdll* 
  (cond-expand 
   (windows-nt "kernel32.dll")
   (windows-ce "coredll.dll")))

(define CreateFile
  (w32:foreign-procedure *kdll* "CreateFileW"
    '(w32api handle lpcwstr dword dword lpvoid dword dword handle)))
(define GENERIC_READ #x80000000)
(define GENERIC_WRITE #x40000000)
(define OPEN_EXISTING 3)

(define CloseHandle
  (w32:foreign-procedure *kdll* "CloseHandle"
    '(w32api bool handle)))

(define GetCommState
  (w32:foreign-procedure *kdll* "GetCommState"
    '(w32api bool handle lpvoid)))

(define SetCommState
  (w32:foreign-procedure *kdll* "SetCommState"
    '(w32api bool handle lpvoid)))

(define EscapeCommFunction 
  (w32:foreign-procedure *kdll* "EscapeCommFunction"
    '(w32api bool handle dword)))
(define SETRTS 3)
(define CLRRTS 4)
(define SETDTR 5)
(define CLRDTR 6)

(define GetLastError
  (w32:foreign-procedure *kdll* "GetLastError" 
    '(w32api dword)))

;(define TransmitCommChar
;  (w32:foreign-procedure *kdll* "TransmitCommChar" 
;    '(w32api bool handle dword)))

(define GetTickCount
  (w32:foreign-procedure *kdll* "GetTickCount" '(w32api dword)))

(define-macro (unwind-protect form . unwind-forms)
  `(dynamic-wind
     (lambda () #t) (lambda () ,form) (lambda () ,@unwind-forms)))

;; Test a system call for error
;;
(define (api-check res msg)
  (if (or (not res) (and (foreign? res) (zero? res)))
    (error msg (GetLastError))
    res))

;; CreateFile returns INVALID_HANDLE_VALUE, not 0, to signal an error
;;
(define (createfile-check res msg)
  (if (and (foreign? res) (eqv? #xffffffff (foreign->integer res)))
    (error msg (GetLastError))
    res))

(w32:declare-foreign-struct DCB 
  (DCBlength BaudRate bitfields wReserved 
    XonLim XoffLim ByteSize Parity StopBits 
    XonChar XoffChar ErrorChar EofChar EvtChar wReserved1)
  #(dword dword dword word
     word word byte byte byte
     byte byte byte byte byte word))

; Some debugging code
;(define *time-trace* '())
;(define (timing-reset) (set! *time-trace* '()))
;(define (timing-list) (map cdr (reverse *time-trace*)))
;(define (timing-log x) 
;  (if (null? *time-trace*) 
;    (set! *time-trace* 
;      (cons (list (current-milliseconds) 0 'start) *time-trace*)))
;  (set! *time-trace* 
;    (let ((cm (current-milliseconds)))
;      (cons (list cm (- cm (caar *time-trace*)) x) *time-trace*))))

;;$ BUGBUG Sleep seems terribly approximate on WCE
;; Consider a (SetThreadPriority (GetCurrentThread) THREAD_PRIORITY_HIGHEST)
;; to alleviate timing problems.
;; As the CM17A isn't very time sensitive, this may not matter.
;;$ BUGBUG 'do' conses.  But the longer we sleep, the coarser our resolution seems.
;; X10 recommends a pulse width of at least 0.5ms, far smaller than the resolution
;; of the system timer.  A greater pulse width allows the CM17A to transmit over
;; greater distances.
;;
(define pulse-hold
  (cond-expand
   (windows-ce
    (lambda ()
      (let ((goal (+ (GetTickCount) time-pulse)))
        (do ((now (GetTickCount) (GetTickCount)))
          ((> now goal)) (sleep 0)))))
   (windows-nt
    (lambda () (sleep time-pulse)))))

(define (bit-to-cm17a h set?)
  (api-check (EscapeCommFunction h (if set? CLRDTR CLRRTS)) "clear dtr or rts")
  (pulse-hold)
  (api-check (EscapeCommFunction h (if set? SETDTR SETRTS)) "set dtr or rts")
  (pulse-hold))

(define (standby-to-cm17a h)
  (api-check (EscapeCommFunction h SETDTR) "set dtr")
  (api-check (EscapeCommFunction h SETRTS) "set rts")
  (sleep time-warmup))

(define (byte-to-cm17a h b)
  (for-each
    (lambda (mask) (bit-to-cm17a h (not (zero? (bit-and b mask)))))
    '(#b10000000 #b1000000 #b100000 #b10000 #b1000 #b100 #b10 #b1)))

;; See http://www.x10.com/manuals/cm17a_proto.txt for the following codes
;;
(define send-command-to-open 
  (let ((housecodes #( #x60 #x70 #x40 #x50 #x80 #x90 #xa0 #xb0
                       #xe0 #xf0 #xc0 #xd0 #x00 #x10 #x20 #x30 ))
        (devicecodes-b2 #(0 0 0 0 0 0 0 0 4 4 4 4 4 4 4 4))
        (devicecodes-b3 #( #x00 #x10 #x08 #x18 #x40 #x50 #x48 #x58
                           #x00 #x10 #x08 #x18 #x40 #x50 #x48 #x58 )))
    (lambda (h cmd house-code device-code)
      (standby-to-cm17a h)
      (gc #f) ; collect garbage before entering time-sensitive section
      (for-each 
        (lambda (byte) (byte-to-cm17a h byte))
        (list 
          #b11010101 
          #b10101010
          (bit-or 
            (vector-ref housecodes house-code) 
            (vector-ref devicecodes-b2 device-code))
          (bit-or 
            (vector-ref devicecodes-b3 device-code) 
            (case cmd
              ((on) #x00)
              ((off) #x20)
              ((bright-005) #x88)
              ((dim-005) #x98)
              ((on-all) #x91) ; following four commands are undocumented
              ((off-all) #x80)
              ((on-lamps) #x94)
              ((off-lamps) #x84)
              (else (error "Unrecognized Firecracker command" cmd))))
          #b10101101)) )))

(define (call-with-open-comm-port proc)
  (let ((h (createfile-check 
             (CreateFile *port* 
               (bit-or GENERIC_READ GENERIC_WRITE) 
               #f #f 
               OPEN_EXISTING #f #f) 
             "Unable to open comm"))
        (dcb (make-DCB)))
    (DCB-DCBlength-set! dcb DCB_sizeof)
    (unwind-protect
      (begin
        (api-check (GetCommState h dcb) "Error getting comm settings")
        ; these bits are fBinary, fTxContinueOnXoff, 
        ; fDtrControl = DTR_CONTROL_ENABLE, and fRtsControl = RTS_CONTROL_ENABLE
        (DCB-bitfields-set! dcb #b00000000000000000001000010010001)
        (api-check (SetCommState h dcb) "Error setting up comm")
        (proc h))
      (CloseHandle h))))

(define (get-house-code arg)
  (if (or (not (string? arg)) (< (string-length arg) 1))
    (error "Invalid house code [e.g. A]:" arg))
  (let ((hc (char-upcase (string-ref arg 0))))
    (if (or (char>? hc #\P) (char<? hc #\A))
      (error "House code may range from A to P; given" arg))
    (- (char->integer hc) (char->integer #\A))))

(define (get-device-code arg)
  (if (or (not (string? arg)) (< (string-length arg) 2))
    (error "Invalid house/device code [e.g. A1]:" arg))
  (let ((dc (string->number (substring arg 1 (string-length arg)))))
    (if (not (number? dc))
      (error "Invalid house/device code [e.g. A1]:" arg))
    (if (or (> dc 16) (< dc 1))
      (error "Device code may range from 1 to 16; given" arg))
    (- (truncate dc) 1)))
 
(define (firecracker-on arg)
  (let ((house-code (get-house-code arg)) (device-code (get-device-code arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (send-command-to-open h 'on house-code device-code)
        (standby-to-cm17a h)))))

(define (firecracker-on-all arg)
  (let ((house-code (get-house-code arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (send-command-to-open h 'on-all house-code 0)
        (standby-to-cm17a h)))))

(define (firecracker-on-lamps arg)
  (let ((house-code (get-house-code arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (send-command-to-open h 'on-lamps house-code 0)
        (standby-to-cm17a h)))))

(define (firecracker-off arg)
  (let ((house-code (get-house-code arg)) (device-code (get-device-code arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (send-command-to-open h 'off house-code device-code)
        (standby-to-cm17a h)))))

(define (firecracker-off-all arg)
  (let ((house-code (get-house-code arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (send-command-to-open h 'off-all house-code 0)
        (standby-to-cm17a h)))))

(define (firecracker-off-lamps arg)
  (let ((house-code (get-house-code arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (send-command-to-open h 'off-lamps house-code 0)
        (standby-to-cm17a h)))))

(define (firecracker-bright brightness house-arg)
  (if (or (< brightness 5) (> brightness 100)) (error "Invalid brightness percentage [5..100]:" brightness))
  (let ((house-code (get-house-code house-arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (do ((i (inexact->exact (/ brightness 5)) (- i 1)))
          ((zero? i))
          (send-command-to-open h 'bright-005 house-code 0))
        (standby-to-cm17a h)))))

(define (firecracker-dim dimness house-arg)
  (if (or (< dimness -100) (> dimness -5)) (error "Invalid dimness percentage[-100..-5]:" dimness))
  (let ((house-code (get-house-code house-arg)))
    (call-with-open-comm-port
      (lambda (h) 
        (do ((i (inexact->exact (/ dimness 5)) (+ i 1)))
          ((zero? i))
          (send-command-to-open h 'dim-005 house-code 0))
        (standby-to-cm17a h)))))