; tmp.grovel --- вспомогательный файл в синтаксисе cffi-grovel, определяющий константы из glibc

(in-package :system)

(include "sys/types.h"
         "sys/stat.h"
         "fcntl.h")

(ctype size  "size_t")
(ctype ssize "ssize_t")

(cenum open-flags
  ((:read-only  "O_RDONLY"))
  ((:write-only "O_WRONLY"))
  ((:create     "O_CREAT")))

; основной файл

; подключаем используемые библиотеки
(require :cffi)
(require :cffi-grovel)
(require :iterate)
(use-package :iterate)

; сюда будут сложены символы, относящиеся к glibc
(defpackage :system
  (:use :cl))

; загружаем определения констант glibc
(load (cffi-grovel:process-grovel-file "tmp.grovel"))

; переходим в пакет system
(in-package :system)

; описываем тип исключения, бросаемого при возникновении проблем в функциях
; glibc
(shadow 'error) ; тут некоторые лисперы могут меня побить, но я предпочитаю не
                ; раздувать свой словарь лишними терминами без необходимости
(define-condition error ()
  ((errno 
     :initarg :errno
     :initform (sb-alien:get-errno))
   (function
     :initarg :function))
  (:report (lambda (condition stream)
             (format stream "~a: ~a~%"
                     (slot-value condition 'function)
                     (sb-int:strerror (slot-value condition 'errno))))))
(export 'error)

; всомогательный макрос. Не люблю писать повторяющийся код
; (defcfun "read" ssize (fd :int) (buf :pointer) (count size))
; раскрывается в
; (progn
;   (shadow "READ")
;   (cffi:defcfun ssize (fd :int) (buf :pointer) (count size))
;   (export (find-symbol "READ")))
(defmacro defcfun (&whole; whole name return-type &rest; args)
  (declare (ignore return-type args))
  (let ((n (string-upcase name)))
    `(progn
       (shadow ,n)
       (cffi:defcfun ,@(cdr whole))
       (export (find-symbol ,n)))))

; объявляем функции из glibc
(defcfun "read"  ssize (fd :int) (buf :pointer) (count size))
(defcfun "write" ssize (fd :int) (buf :pointer) (count size))
(defcfun "open" :int (pathname :string) (flags :int) &rest;)
(defcfun "close" :int (fd :int))

; этот макрос раскрывается в код, который открывает файл, выполняет код в body,
; подставляя вместо fd полученный файловый дескриптор, и закрывает файл, всё с
; проверкой значений, возвращаемых glibc и учётом вылета возможных исключений в body
(shadow 'with-open-file)
(defmacro with-open-file ((fd filename &rest; flags) &body; body)
  `(let ((,fd (open ,filename 
                    (reduce #'logior (list ,@flags)
                            :key (lambda (flag)
                                   (cffi:foreign-enum-value 'open-flags 
                                                            flag))))))
     (when (= ,fd -1)
       (cl:error 'error :function 'open))
     (unwind-protect (progn ,@body)
       (when (= (close ,fd) -1)
         (cl:error 'error :function 'close)))))
(export 'with-open-file)

; возвращаемся в исходный пакет из system
(in-package :cl-user)

; класс foreign-object я недавно написал для одного из своих проектов. Он
; хранит указатель в кучу, которая, как известно, недоступна сборщику мусора, и
; вызывает деструктор при уничтожении объекта foreign-object. Значение
; указателя можно менять; при желании можно вызвать деструктор вручную
(defclass foreign-object ()
  ((object
     :initarg :object
     :initform (cffi:null-pointer)
     :accessor *foreign-object)))

; функция доступа к указателю (геттер)
(defgeneric foreign-object (object)
  (:method ((object foreign-object)) 
     (car (*foreign-object object))))

; сеттер
(defgeneric (setf foreign-object) (pointer object)
  (:method (pointer (object foreign-object)) 
     (setf (car (*foreign-object object)) pointer)))

; функция initialize-instance доовольно близко описывается термином C++
; "конструктор", хотя, конечно, есть ньюансы
(defmethod initialize-instance :after ((object foreign-object)
                                       &key; (destructor #'cffi:foreign-free)
                                       &allow;-other-keys)
  (let ((wrapper (cons (slot-value object 'object) nil)))
    (setf (slot-value object 'object) wrapper)
    (finalize object (lambda () (funcall destructor (car wrapper))))))

; функция LoveSan'a
(defun swap-u32-bytes (x) 
  (declare (type (unsigned-byte 32) x)) 
  (logand 
    #xffffffff 
    (logior 
      (ash (ldb (byte 8 24) x) 0) 
      (ash (ldb (byte 8 0)  x) 24) 
      (ash (ldb (byte 8 16) x) 8) 
      (ash (ldb (byte 8 8)  x) 16)))) 

; считывает матрицу в массив C и отдаёт указатель наружу
(defun read-u32-matrix (filename m n &optional; reverse-endian)
  (system:with-open-file (fd (namestring filename) :read-only)
    (let* ((size (* m n (cffi:foreign-type-size :uint32)))
           (array (make-instance 'foreign-object 
                                 :object (cffi:foreign-alloc :uint32 
                                                             :count size))))
      ; у меня нет опыта работы с большими файлами; оптимизируйте тут сами
      (unless (= (system:read fd (foreign-object array) size) size)
        (error 'system:error :function 'system:read))
      (when reverse-endian
        (iter
          (for i from 0 below (* m n))
          (swap-u32-bytes (cffi:mem-ref array :uint32 i))))
      array)))

; наш рабочий класс изображения
(defclass image ()
  ((width
     :type fixnum
     :initarg :width
     :reader width)
   (height
     :type fixnum
     :initarg :height
     :reader height)
   (data
     :type foreign-object
     :initarg :data
     :reader data*)))

; для упрощения доступа. По-хорошему это надо как-то запихнуть в определение
; объекта foreign-object, но я не придумал как
(defgeneric data (image)
  (:method ((image image)) (foreign-object (data* image))))

; если конструктору изображения передан параметр filename, считываем данные из
; этого файла, иначе надеемся на автоматическую инициализацию параметром data.
; Если не было передано ни того, ни другого, указатель в data будет NULL
(defmethod initialize-instance :after ((instance image) 
                                       &key; width height data filename 
                                            reverse-endian)
  (declare (ignore data))
  (when filename
    (setf (slot-value instance 'data) 
          (read-u32-matrix filename width height reverse-endian))))

; сделаем тестовый файл "data.dat", забив его значениями от 1 до 25
(system:with-open-file (fd "data.dat" :write-only :create)
  (let ((buf (cffi:foreign-alloc :uint32 :count 25)))
    (unwind-protect 
      (iter
        (for i from 0 below 25)
        (setf (cffi:mem-aref buf :uint32 i) i)
        (finally
          (let ((size (* 25 (cffi:foreign-type-size :uint32))))
            (unless (= (system:write fd buf size) size)
              (error 'system:error :function 'system:write)))))
      (cffi:foreign-free buf))))

; тут начинается собственно пример макросов. Определим макрос, генерирующий
; функцию, итерирующую по массиву путём, зависящим от параметра макроса. Имя
; функции определяется переменной color
(macrolet ((defmap-color (color xstep ystep)
             `(defun ,(intern (format nil "MAP-~s" color)) (function image)
                (iter
                  (with width  = (width image))
                  (with height = (height image))
                  (with data   = (data image))
                  ,ystep
                  (let ((x0 (* y width)))
                    (iter
                      ,xstep
                      (funcall function 
                               x y 
                               (cffi:mem-aref data :uint32 (+ x0 x)))))))))
  ; определим map-red
  (defmap-color red 
                (for x from 1 below width  by 2)
                (for y from 1 below height by 2))
  ; map-green
  (defmap-color green
                (for x from (if (oddp y) 1 0) below width by 2)
                (for y from 0 below height))
  ; и map-blue
  (defmap-color blue
                (for x from 0 below width  by 2)
                (for y from 0 below height by 2)))

; Вышеприведённая форма разворачивается в такой аналог C:
; void map_red(void (*function)(int, int, uint32_t), struct image* image) {
;  for (int y = 1; y < image->height; y += 2)
;   for (int x = 1; x < image->width; x += 2)
;    function(x, y, image->data[y * image->width + x]);
; };
;
; void map_green(void (*function)(int, int, uint32_t), struct image* image) {
;  for (int y = 0; y < image->height; ++y)
;   for (int x = (y+1)%2; x < image->width; x += 2)
;    function(x, y, image->data[y * image->width + x]);
; };
;
; void map_blue(void (*function)(int, int, uint32_t), struct image* image) {
;  for (int y = 0; y < image->height; y += 2)
;   for (int x = 0; x < image->width; x += 2)
;    function(x, y, image->data[y * image->width + x]);
; }

(let* (; считаем файл
       (image (make-instance 'image :width 5 :height 5 :filename #p"data.dat"))
       ; посчитаем подходящий размер гистограммы найди максимальный размер
       ; элемента в массиве. Думаю, в реальной задаче он уже известен их других
       ; соображений
       (max (iter
              (with data = (data image))
              (for i from 0 below (* (width image) (height image)))
              (maximize (cffi:mem-aref data :uint32 i))))
       ; создадим три гистограммы
       (hist-red #1=(make-array (1+ max) :element-type 'fixnum :initial-element 0))
       (hist-green #1#)
       (hist-blue #1#))
  (flet (; объявим функцию, возвращающую замыкание, увеличивающее значение в
         ; соответствующей гистограмме. Интерфейс замыкания подходит для
         ; использования в качестве параметра map-red, map-green и map-blue
         (collect-hist (hist)
           (lambda (x y value)
             (declare (ignore x y))
             (incf (aref hist value)))))
    ; собираем данные из массива
    (map-red   (collect-hist hist-red)   image)
    (map-green (collect-hist hist-green) image)
    (map-blue  (collect-hist hist-blue)  image))
  ; записываем результат в файл "histograms"
  (with-open-file &#40;f #p"histograms" :direction :output :if-exists :supersede&#41;
    (format f "~10t ~10@a ~10@a ~10@a~%" "red" "green" "blue")
    (iter
      (for i from 0 to max)
      (for red   in-vector hist-red)
      (for green in-vector hist-green)
      (for blue  in-vector hist-blue)
      (format f "~10d ~10d ~10d ~10d~%" i red green blue))))