;; see: "Inside the Qt 4 Containers"
;; http://doc.trolltech.com/qq/qq19-containers.html#sequentialcontainers

(in-package :cl-smoke.qt.core)

(defcfun cl-smoke-make-qvector :pointer)
(defcfun cl-smoke-delete-qvector :void
  (vector :pointer))

(defbitfield qvector-data-flags
  :sharable
  :capacity)

(defcstruct qvector-data
  (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int)))
  (alloc :int)
  (size :int)
  (flags qvector-data-flags))

(defcstruct qvector-type-data
  (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int)))
  (alloc :int)
  (size :int)
  (flags qvector-data-flags)
  (array :pointer))

;; FIXME We assume QVector to be a POD struct, which is not
;; neccesarily the case.
(defcstruct qvector
  (data (:pointer qvector-data)))

(defun qvector-size (qvector)
  (foreign-slot-value (foreign-slot-value qvector 'qvector 'data)
                      'qvector-data 'size))

(defun qvector-elt (qvector index element-type)
  (pointer-to-lisp
   (cffi:inc-pointer
    (foreign-slot-pointer (foreign-slot-value qvector 'qvector 'data)
                          'qvector-type-data 'array)
    (* index (type-size element-type)))
   element-type))

(defun from-qvector (qvector element-type)
  (let ((result (make-array (qvector-size qvector))))
    (dotimes (i (length result) result)
      (setf (elt result i)
            (qvector-elt qvector i element-type)))))

(defcfun memcpy :pointer
  (destination :pointer)
  (source :pointer)
  (size :unsigned-int))

(defun make-qvector (element-type elements)
  (let* ((length (length elements))
         (element-size (type-size element-type))
         (data (foreign-alloc :char :count (+ (foreign-type-size 'qvector-data)
                                              (* length element-size))))
         (darray (foreign-slot-pointer data 'qvector-type-data 'array))
         (vector (cl-smoke-make-qvector)))
    (unless (stack-p element-type)
      (error "FIXME: TODO"))
    (if (class-p element-type)
        (dotimes (i length)
          (memcpy (inc-pointer darray (* i element-size))
                  (pointer (elt elements i))
                  element-size))
        (dotimes (i length)
          (setf (mem-aref darray (type-foreign-keyword element-type)  i)
                (elt elements i))))
    (setf (mem-ref data :int) 1) ;; ref count
    (with-foreign-slots ((ref alloc size flags)
                         data qvector-data)
      (setf alloc length ;; allocated size
            size length 
            flags :sharable)
      (setf (foreign-slot-value vector 'qvector 'data)
            data))
    vector))

(defun deref (basic-atomic-int-pointer)
  ;; decrement and return true when the new value is non-zero
  (cxx:deref
   (make-instance 'qt:basic-atomic-int :pointer basic-atomic-int-pointer)))

(defun free-qvector (vector)
  (unless (null-pointer-p (foreign-slot-value vector 'qvector 'data))
    (let ((data (foreign-slot-value vector 'qvector 'data)))
      (unless (deref (foreign-slot-pointer data 'qvector-type-data 'ref))
        (foreign-free data)))
    (setf (foreign-slot-value vector 'qvector 'data)
          (null-pointer)))
  (cl-smoke-delete-qvector vector))

(defmacro define-qvector-translations (element-type lisp-type)
  `(progn
     (defun ,(symbolicate 'from-vector- element-type) (elements)
       (make-cleanup-pointer
        (make-qvector (make-smoke-type *smoke-module* ,element-type)
                      elements)
        #'free-qvector))
     (defun ,(symbolicate 'vector- element-type '-p) (sequence)
       (every #'(lambda (element)
                  (typep element ',lisp-type))
              sequence))
     (defun ,(symbolicate 'to-vector- element-type) (pointer)
       (from-qvector pointer (make-smoke-type *smoke-module* ,element-type)))
     (define-from-lisp-translation (,(format nil "QVector<~A>" element-type)
                                     ;; FIXME QImage::setColorTable
                                     ;; has an "const QVector<QRgb>"
                                     ;; argument!
                                     ,(format nil "const QVector<~A>" element-type)
                                     ,(format nil "const QVector<~A>&" element-type))
         (and vector
              (satisfies ,(symbolicate 'vector- element-type '-p)))
       ,(symbolicate 'from-vector- element-type))
     (define-to-lisp-translation (,(format nil "QVector<~A>" element-type)
                                   ,(format nil "const QVector<~A>&" element-type))
         ,(symbolicate 'to-vector- element-type)
       free-qvector)))
      
(define-qvector-translations "double" double-float)