;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               binary-packet.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This package exports a macro to define structures with typed fields
;;;;    and corresponding binary packets, and serialization and
;;;;    deserialization methods.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@ogamita.com>
;;;;MODIFICATIONS
;;;;    2011-04-07 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(defpackage "COM.OGAMITA.FGFS.BINARY-PACKET"
  (:use "COMMON-LISP")
  (:export
   "DEFINE-MESSAGE" "SERIALIZE" "DESERIALIZE")
  (:documentation "

This package exports a macro to define structures with typed fields
and corresponding binary packets, and serialization and
deserialization methods.

"))
(in-package "COM.OGAMITA.FGFS.BINARY-PACKET")




(defmacro gen-ieee-encoding (name type exponent-bits mantissa-bits)
  ;; Thanks to ivan4th (~ivan_iv@nat-msk-01.ti.ru) for correcting an off-by-1
  `(progn
     (defun ,(intern (format nil "~A-TO-IEEE-754" name) (symbol-package name))  (float)
       (multiple-value-bind (mantissa exponent sign)
           (integer-decode-float float)
         (dpb (if (minusp sign) 1 0)
              (byte 1 ,(1- (+ exponent-bits mantissa-bits)))
              (dpb (+ ,(+ (- (expt 2 (1- exponent-bits)) 2) mantissa-bits)
                      exponent)
                   (byte ,exponent-bits ,(1- mantissa-bits))
                   (ldb (byte ,(1- mantissa-bits) 0) mantissa)))))
     (defun ,(intern (format nil "IEEE-754-TO-~A" name) (symbol-package name))  (ieee)
       (let ((aval (scale-float
                    (coerce
                     (dpb 1 (byte 1 ,(1- mantissa-bits))
                          (ldb (byte ,(1- mantissa-bits) 0) ieee))
                     ,type)
                    (- (ldb (byte ,exponent-bits ,(1- mantissa-bits))
                            ieee)
                       ,(1- (expt 2 (1- exponent-bits)))
                       ,(1- mantissa-bits)))))
         (if (zerop (ldb (byte 1 ,(1- (+ exponent-bits mantissa-bits))) ieee))
             aval
             (- aval))))))


(gen-ieee-encoding float-32 'single-float  8 24)
(gen-ieee-encoding float-64 'double-float 11 53)


(defun test-ieee-read-double ()
  (with-open-file (in "value.ieee-754-double"
                      :direction :input :element-type '(unsigned-byte 8))
    (loop while (< (file-position in) (file-length in))
       do (loop repeat 8 for i = 1 then (* i 256)
             for v = (read-byte in) then (+ v (* i (read-byte in)))
             finally (progn
                       (let ((*print-base* 16)) (princ v))
                       (princ " ")
                       (princ (IEEE-754-TO-FLOAT-64 v))
                       (terpri))))))

(defun test-ieee-read-single ()
  (with-open-file (in "value.ieee-754-single"
                      :direction :input :element-type '(unsigned-byte 8))
    (loop while (< (file-position in) (file-length in))
       do (loop repeat 4 for i = 1 then (* i 256)
             for v = (read-byte in) then (+ v (* i (read-byte in)))
             finally (progn
                       (let ((*print-base* 16)) (princ v))
                       (princ " ")
                       (princ (IEEE-754-TO-FLOAT-32 v))
                       (terpri))))))

(defun test-single-to-ieee (&rest args)
  (dolist (arg args)
    (format t "~16,8R ~A~%"
            (float-32-to-ieee-754 (coerce arg 'single-float)) arg)))

(defun test-double-to-ieee (&rest args)
  (dolist (arg args)
    (format t "~16,16R ~A~%"
            (float-64-to-ieee-754 (coerce arg 'double-float)) arg)))



(defun deserialize-unsigned-byte-64 (buffer offset)
  (dpb (aref buffer offset)
       (byte 8 56)
       (dpb (aref buffer (1+ offset))
            (byte 8 48)
            (dpb (aref buffer (+ 2 offset))
                 (byte 8 40)
                 (dpb (aref buffer (+ 3 offset))
                      (byte 8 32)
                      (dpb (aref buffer (+ 4 offset))
                           (byte 8 24)
                           (dpb (aref buffer (+ 5 offset))
                                (byte 8 16)
                                (dpb (aref buffer (+ 6 offset))
                                     (byte 8 8)
                                     (aref buffer (+ 7 offset))))))))))

(defun deserialize-unsigned-byte-32 (buffer offset)
  (dpb (aref buffer offset)
       (byte 8 24)
       (dpb (aref buffer (1+ offset))
            (byte 8 16)
            (dpb (aref buffer (+ 2 offset))
                 (byte 8 8)
                 (aref buffer (+ 3 offset))))))

(defun deserialize-signed-byte-32 (buffer offset)
  (let ((word (deserialize-unsigned-byte-32 buffer offset)))
     (if (logbitp 31 word)
         (dpb word (byte 32 0) -1)
         word)))

(defun deserialize-signed-byte-64 (buffer offset)
  (let ((word (deserialize-unsigned-byte-64 buffer offset)))
    (if (logbitp 63 word)
        (dpb word (byte 64 0) -1)
        word)))


(defun deserialize-single-float (buffer offset)
  (handler-case
      (let ((bytes  (deserialize-signed-byte-32 buffer offset)))
        (if (zerop bytes)
            0.0f0
            (IEEE-754-TO-FLOAT-32 bytes)))
    (error (err)
      (format *error-output* "While deserialize-double-float at offset ~D, got ~8,'0X"
              offset  (deserialize-signed-byte-32 buffer offset))
      (error err))))

(defun deserialize-double-float (buffer offset)
  (handler-case
      (let ((bytes  (deserialize-signed-byte-64 buffer offset)))
        (if (zerop bytes)
            0.0d0
            (IEEE-754-TO-FLOAT-64 bytes)))
    (error (err)
      (format *error-output* "While deserialize-double-float at offset ~D, got ~16,'0X"
              offset  (deserialize-signed-byte-64 buffer offset))
      (error err))))



(defun serialize-unsigned-byte-32 (value buffer offset)
  (setf (aref buffer      offset)  (ldb (byte 8 56) value)
        (aref buffer (+ 1 offset)) (ldb (byte 8 48) value)
        (aref buffer (+ 2 offset)) (ldb (byte 8 40) value)
        (aref buffer (+ 3 offset)) (ldb (byte 8 32) value)
        (aref buffer (+ 4 offset)) (ldb (byte 8 24) value)
        (aref buffer (+ 5 offset)) (ldb (byte 8 16) value)
        (aref buffer (+ 6 offset)) (ldb (byte 8  8) value)
        (aref buffer (+ 7 offset)) (ldb (byte 8  0) value))
  (+ 8 offset))

(defun serialize-unsigned-byte-32 (value buffer offset)
  (setf (aref buffer      offset)  (ldb (byte 8 24) value)
        (aref buffer (+ 1 offset)) (ldb (byte 8 16) value)
        (aref buffer (+ 2 offset)) (ldb (byte 8  8) value)
        (aref buffer (+ 3 offset)) (ldb (byte 8  0) value))
  (+ 4 offset))

(defun serialize-signed-byte-32 (value buffer offset)
  (serialize-unsigned-byte-32 value buffer offset))

(defun serialize-single-float (value buffer offset)
  (serialize-unsigned-byte-64 (FLOAT-32-TO-IEEE-754 value) buffer offset)
  (+ 4 offset))

(defun serialize-double-float (value buffer offset)
  (serialize-unsigned-byte-64 (FLOAT-64-TO-IEEE-754 value) buffer offset)
  (+ 8 offset))



(eval-when (:execute :compile-toplevel :load-toplevel)
   (defun type-initial-value (type)
     (if (atom type)
         (ecase type
           (double-float 0.0d0)
           (single-float 0.0f0))
         (ecase (first type)
           (vector
            (destructuring-bind (vector element-type size) type
              `(make-array ,size
                           :element-type ',element-type
                           :initial-element ,(type-initial-value element-type))))
           (unsigned-byte 0)
           (signed-byte   0))))

   (defun type-size (type)
     (if (atom type)
         (ecase type
           (double-float 8)
           (single-float 4))
         (ecase (first type)
           (vector
            (destructuring-bind (vector element-type size) type
              (* size (type-size element-type))))
           ((unsigned-byte signed-byte) (ceiling (second type) 8)))))

   (defun compute-message-size (fields)
     (reduce (function +) fields :key (lambda (field) (type-size (second field))))))


(defmacro define-message (name options &rest fields)
  (flet ((generate-simple-type-serialize (value type offset)
           (if (listp type)
               (ecase (first type)
                 (unsigned-byte
                  (ecase (second type)
                    (32 `(serialize-unsigned-byte-32 ,value buffer ,offset))
                    (64 `(serialize-unsigned-byte-64 ,value buffer ,offset))))
                 (signed-byte
                  (ecase (second type)
                    (32 `(serialize-signed-byte-32 ,value buffer ,offset))
                    (64 `(serialize-signed-byte-64 ,value buffer ,offset)))))
               (ecase type
                 (single-float `(serialize-single-float ,value buffer ,offset))
                 (double-float `(serialize-double-float ,value buffer ,offset)))))
         (generate-simple-type-deserialize (type offset)
           (if (listp type)
               (ecase (first type)
                 (unsigned-byte
                  (ecase (second type)
                    (32 `(deserialize-unsigned-byte-32 buffer ,offset))
                    (64 `(deserialize-unsigned-byte-64 buffer ,offset))))
                 (signed-byte
                  (ecase (second type)
                    (32 `(deserialize-signed-byte-32 buffer ,offset))
                    (64 `(deserialize-signed-byte-64 buffer ,offset)))))
               (ecase type
                 (single-float `(deserialize-single-float buffer ,offset))
                 (double-float `(deserialize-double-float buffer ,offset))))))
    `(progn
       (defstruct ,name
         ,@(mapcar (lambda (field)
                     (destructuring-bind (name type &optional (default-value nil default-value-p)) field
                       `(,name ,(if default-value-p
                                    default-value
                                    (type-initial-value type))
                               :type ,type)))
                   fields))
       (defun ,(intern (format nil "MAKE-~A-BUFFER" name) (symbol-package name)) ()
         (make-array ,(compute-message-size fields)
                     :element-type '(unsigned-byte 8)
                     :initial-element 0))
       (defmethod serialize ((self ,name) buffer)
         ,@(loop
              :for offset = 0 :then (+ offset size)
              :for (field-name type) :in fields
              :for size = (type-size type)
              :collect (if (and (listp type) (eql 'vector (first type)))
                           (destructuring-bind (vector element-type size) type
                             `(let ((v (,(intern (format nil "~A-~A" name field-name)
                                                 (symbol-package name)) self)))
                                ,@(loop
                                     :with element-size = (type-size element-type)
                                     :for i :from 0 :below size
                                     :for voffset = offset :then (+ voffset element-size)
                                     :collect (generate-simple-type-serialize `(aref v ,i) element-type voffset))))
                           (generate-simple-type-serialize `(,(intern (format nil "~A-~A" name field-name)
                                                                        (symbol-package name)) self)
                                                             type offset)))
         buffer)
       (defmethod deserialize ((self ,name) buffer)
         ,@(loop
              :for offset = 0 :then (+ offset size)
              :for (field-name type) :in fields
              :for size = (type-size type)
              :collect (if (and (listp type) (eql 'vector (first type)))
                           (destructuring-bind (vector element-type size) type
                             `(let ((v (,(intern (format nil "~A-~A" name field-name)
                                                 (symbol-package name)) self)))

                                (setf ,@(loop
                                           :with element-size = (type-size element-type)
                                           :for i :from 0 :below size
                                           :for voffset = offset :then (+ voffset element-size)
                                           :collect `(aref v ,i)
                                           :collect (generate-simple-type-deserialize element-type voffset)))))
                           `(setf (,(intern (format nil "~A-~A" name field-name)
                                            (symbol-package name)) self)
                                  ,(generate-simple-type-deserialize type offset))))
         self)
       ',name)))


;;;; THE END ;;;;
ViewGit