refactored ebus code

1 files changed, 208 insertions, 0 deletions

diff --git a/ebus-racket/ebus/layer7.rkt b/ebus-racket/ebus/layer7.rkt
new file mode 100644
index 0000000..1ecf271
--- /dev/null
+++ b/ebus-racket/ebus/layer7.rkt
@@ -0,0 +1,208 @@
+#lang racket/base
+(require 
+  (only-in racket/bool false?)
+  (only-in racket/function curry)
+  (only-in xml collapse-whitespace
+           xexpr-drop-empty-attributes
+           xml->xexpr
+           document-element
+           read-xml)
+  (only-in "../3rdparty/xexpr-path/main.rkt"
+           xexpr-path-first
+           xexpr-path-list)
+  (prefix-in layer2- "layer2.rkt"))
+
+(define-logger ebus7)
+
+(define (ersatzwert) 'ersatzwert)
+(define (ersatzwert? v) (eq? (ersatzwert) v))
+
+(define (read-ebus-xml path)
+  (let* ([in (open-input-file path)]
+         [xexpr (parameterize ([collapse-whitespace #t]
+                               [xexpr-drop-empty-attributes #t])
+                  (xml->xexpr (document-element (read-xml in))))])
+    (close-input-port in)
+    xexpr))
+
+(define definition (make-parameter null))
+
+(define (paket ebus-paket)
+  (define primaryCommand (number->string (layer2-ebus-paket-primaryCommand ebus-paket)))
+  (define secondaryCommand (number->string (layer2-ebus-paket-secondaryCommand ebus-paket)))
+  (log-ebus7-debug "Lookup paket primaryCommand=~a secondaryCommand=~a" primaryCommand secondaryCommand)
+  (xexpr-path-first (list 'packets 'packet (list 'primary primaryCommand)
+                          (list 'secondary secondaryCommand)) (definition)))
+
+(define (paket-name xexpr)
+  (xexpr-path-first '((name)) xexpr))
+
+(define (paket-fields paket-definition)
+  (filter 
+   (lambda (i) (and (pair? i) (member (car i) '(bit bcd data1b data1c byte data2b data2c word byteEnum))))
+   (xexpr-path-list '(fields *) paket-definition)))
+
+;; returns the full device-definition
+(define (device address)
+  (xexpr-path-first (list 'devices 'device (list 'address (number->string address))) (definition)))
+
+;; returns device-name in a list or empty-list
+(define (device-name address)
+  (xexpr-path-first (list 'devices 'device (list 'address (number->string address)) '(name)) (definition)))
+
+(define (paket-parse ebus-paket)
+  (define paket-definition (paket ebus-paket))
+  (define source-device-name (device-name (layer2-ebus-paket-source ebus-paket)))
+  (cond ((and (not (false? paket-definition)) (not (false? source-device-name)))
+         (define paket-id (string-append source-device-name "." (paket-name paket-definition)))
+         (define decoders (map (lambda (field) (create-decoder paket-id field)) (paket-fields paket-definition)))
+         (define payload (layer2-ebus-paket-payload ebus-paket))
+         (for/list ([decoder decoders])
+           (decoder payload)))
+        (else (void (log-ebus7-info "Unknown Paket from source ~s(~s): ~s" 
+                                    (layer2-ebus-paket-source ebus-paket) 
+                                    source-device-name 
+                                    ebus-paket)))))
+
+
+(define (create-decoder paket-id field)
+  (define type (car field))
+  (define name (string-append paket-id "." (xexpr-path-first '((name)) field)))
+  (define offset (string->number (xexpr-path-first '((offset)) field)))
+  (define decoder (hash-ref decoder-table type #f))
+  (cond ((false? decoder) (void (log-ebus7-warning "No decoder for type ~s" type)))
+        (else (curry (car decoder) name field offset))))
+
+(define decoder-table
+  (make-hash (list
+              (list 'bit (lambda (name field offset payload)
+                           (list name 'bit (field-decoder-bit (list-ref payload offset)))))
+              (list 'byte (lambda (name field offset payload)
+                            (list name 'byte (field-decoder-byte (list-ref payload offset)))))
+              (list 'bcd (lambda (name field offset payload)
+                           (list name 'bcd (field-decoder-bcd (list-ref payload offset)))))
+              (list 'data1b (lambda (name field offset payload)
+                              (list name 'data1b (field-decoder-data1b (list-ref payload offset)))))
+              (list 'data1c (lambda (name field offset payload)
+                              (list name 'data1c (field-decoder-data1c (list-ref payload offset)))))
+              (list 'data2b (lambda (name field offset payload)
+                              (list name 'data2b (field-decoder-data2b 
+                                                  (list-ref payload offset)
+                                                  (list-ref payload (+ offset 1))))))
+              (list 'data2c (lambda (name field offset payload)
+                              (list name 'data2c 
+                                    (field-decoder-data2c (list-ref payload offset) (list-ref payload (+ offset 1))))))
+              (list 'word (lambda (name field offset payload)
+                            (list name 'word (field-decoder-word (list-ref payload offset) (list-ref payload (+ offset 1))))))
+              (list 'byteEnum (lambda (name field offset payload)
+                                (list name 'byteEnum (field-decoder-byteEnum (list-ref payload offset) field))))
+              )))
+
+;; type bit
+(define (field-decoder-bit value)
+  (cond ((= value 1) 1)
+        (else 0)))
+
+;; type byte
+(define (field-decoder-byte value)
+  (cond ((= value #xff) (ersatzwert))
+        (else value)))
+
+;; type data1b
+(define (field-decoder-data1b value)
+  (if (= value #x80)
+      (ersatzwert)
+      (cond ((= 1 (arithmetic-shift value -7))
+             (* -1 (+ 1 (bitwise-xor #xff value))))
+            (else value))))
+
+;; type data1c
+(define (field-decoder-data1c value)
+  (if (= value #xff)
+      (ersatzwert)
+      (/ value 2.0)))
+
+;; type data2b
+(define (field-decoder-data2b lowByte highByte)
+  (if (and (= highByte 128)  (= lowByte 0))
+      (ersatzwert)
+      (if (= (bitwise-and highByte 128) 128)
+          (* -1 
+             (+ (+ 256 (bitwise-not highByte))
+                (/ (+ 256 (bitwise-not (+ lowByte 1))) 256.0)))
+          (+ highByte (/ lowByte 256.0)))))
+
+;; type data2c
+;;    Beispiel für die Berechnung:
+;;    if ((x & 8000h) == 8000h) // y negativ
+;;    y = - [dez(High_Byte(!x)) 16 + dez(High_Nibble (Low_Byte (!x)))
+;;    + (dez(Low_Nibble (Low_Byte (!x))) +1 ) / 16]
+;;    else                       // y positiv
+;;    y = dez(High_Byte(x)) 16 + dez(High_ Nibble (Low Byte (x)))
+;;    + dez(Low_ Nibble (Low Byte (x))) / 16
+(define (field-decoder-data2c lowByte highByte)
+  (define (lowNibble v)
+    (bitwise-and v #x0f))
+  (define (highNibble v)
+    (arithmetic-shift v -4))
+  (define (u-not v)
+    (+ 256 (bitwise-not v)))
+  
+  (if (and (= highByte 128)  (= lowByte 0))
+      (ersatzwert)
+      (if (= (bitwise-and highByte 128) 128)
+          (* -1
+             (+ (arithmetic-shift (u-not highByte) 4)
+                (highNibble (u-not lowByte))
+                (/ (+ (lowNibble (u-not lowByte)) 1)
+                   16.0)))
+          (+ (arithmetic-shift highByte 4)
+             (highNibble lowByte)
+             (/
+              (lowNibble lowByte)
+              16)))))
+
+;; type byteEnum
+(define (field-decoder-byteEnum value field-definition)
+  (define (pred l)
+    (= value (list-ref l 0)))
+  (define all-options (for/list ([option (xexpr-path-list '(option) field-definition)])
+                        (list (string->number (xexpr-path-first '((value)) option)) ;; '(value name)
+                              (xexpr-path-first '((name)) option))))
+  (define options (filter pred all-options))
+  (cond ((= (length options) 1)
+         (list-ref (car options) 1))
+        (else (format "<undefined:~a>" value))))
+
+;; type word
+(define (field-decoder-word lowByte highByte)
+  (define value
+    (+ lowByte (arithmetic-shift highByte 8)))
+  (if (= value #xffff)
+      (ersatzwert)
+      value))
+
+;; type bcd
+(define (field-decoder-bcd value)
+  (cond ((= value #xff) (ersatzwert))
+        (else (+ (bitwise-and value #x0f)
+                 (* (arithmetic-shift value -4) 10)))))
+
+;; read one ebus-paket or eof from input-port
+;; or return #<eof>
+(define (read-ebus input-port)
+  (define paket (layer2-read-ebus input-port))
+  (cond ((layer2-ebus-paket? paket)
+         (paket-parse paket))
+        (else paket)))
+
+(provide ersatzwert
+         ersatzwert?
+         read-ebus-xml
+         paket
+         paket-parse
+         paket-fields
+         device
+         definition
+         ;; read ebus from port an return fields from next paket
+         read-ebus)