; 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 (f #p"histograms" :direction :output :if-exists :supersede)
(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))))Add a code snippet to your website: www.paste.org