example.lisp

   1 ;; $ LD_PRELOAD=/usr/lib64/libv4l/v4l2convert.so sbcl --load example.lisp
   2
   3 (asdf:oos 'asdf:load-op :cl-v4l2)
   4 (asdf:oos 'asdf:load-op :cl-gtk2-gtkglext)
   5 (asdf:oos 'asdf:load-op :bordeaux-threads)
   6
   7 (defpackage :test-v4l2
   8   (:use :common-lisp :gtk :gtkglext))
   9
  10 (in-package :test-v4l2)
  11
  12 (defvar *capture-device* "/dev/video0")
  13 (defparameter *capture-fd* nil)
  14
  15 ;; what we want from camera
  16 (defvar *want-width* 352)
  17 (defvar *want-height* 288)
  18
  19 ;; what we really get
  20 (defparameter *got-width* nil)
  21 (defparameter *got-height* nil)
  22
  23 (defparameter *camera-widget* nil)
  24 (defparameter *camera-data* nil)
  25 (defparameter *camera-data-lock* (bt:make-lock "Camera data lock"))
  26
  27 (defparameter *cap-thread-stop* nil)
  28
  29 (defparameter *render-thread-stop* (bt:make-condition-variable))
  30 (defparameter *render-thread-lock* (bt:make-lock "Render thread lock"))
  31
  32 (defmacro without-errors (&body body)
  33   `(handler-case (progn ,@body)
  34      (error (c) (format t "suppressed error: ~A~%" c) nil)))
  35
  36 (defun char-at (pos data)
  37   (code-char (ldb (byte 8 (* 8 pos)) data)))
  38
  39 (defun format-string (pixfmt)
  40   (format nil "~C~C~C~C"
  41           (char-at 0 pixfmt)
  42           (char-at 1 pixfmt)
  43           (char-at 2 pixfmt)
  44           (char-at 3 pixfmt)))
  45
  46 (defun diagnose (fd)
  47   (let ((caps (v4l2:query-capabilities fd)))
  48     (format t (v4l2:%device-info caps))
  49     (unless (v4l2:capable caps v4l2:cap-video-capture)
  50       (error "not a capture device"))
  51     (unless (v4l2:capable caps v4l2:cap-streaming)
  52       (error "not a streaming device"))
  53     (when (v4l2:capable caps v4l2:cap-tuner)
  54       (without-errors
  55           (loop for idx from 0 do
  56                (progn
  57                  (v4l2:get-tuner-params fd idx)
  58                  ;; show tuner params
  59                  ))))
  60
  61     (without-errors
  62         (loop for idx from 0 do
  63              (with-slots (v4l2:index v4l2:name v4l2:type v4l2:tuner)
  64                  (v4l2:get-input-params fd idx)
  65                (format t "input [~D] name: ~A, type ~A~%"
  66                        v4l2:index
  67                        v4l2:name
  68                        (if (= v4l2:type v4l2:input-type-tuner) "tuner" "camera"))
  69                (when (= v4l2:type v4l2:input-type-tuner)
  70                  (format t "input [~D] connected to tuner ~D~%" v4l2:index v4l2:tuner))
  71
  72                (without-errors
  73                    (loop for idx1 from 0 do
  74                         (with-slots (v4l2:index v4l2:name)
  75                             (v4l2:get-input-standard fd idx1)
  76                           (format t "input [~D] std [~D] name: ~A~%"
  77                                   idx v4l2:index v4l2:name)))))))
  78
  79     (v4l2:set-input fd 0)               ; some cameras don't set input by default
  80
  81     (without-errors
  82         (loop for idx from 0 do
  83              (with-slots (v4l2:index v4l2:pixelformat) (v4l2:get-format fd idx)
  84                (format t "format [~D] ~S~%" v4l2:index
  85                        (format-string v4l2:pixelformat)))))))
  86
  87 (defun device-init (fd)
  88   (v4l2:set-input fd 0)
  89   (without-errors
  90       (v4l2:set-control fd v4l2:cid-exposure 0.05))
  91   (format t "set ~Dx~D, format ~S~%" *want-width* *want-height*
  92           (format-string v4l2:pix-fmt-rgb24))
  93   (v4l2:set-image-format fd *want-width* *want-height* v4l2:pix-fmt-rgb24)
  94   (with-slots (v4l2:width v4l2:height v4l2:sizeimage v4l2:pixelformat)
  95       (v4l2:format-pix (v4l2:get-image-format fd))
  96     (setf *got-width* v4l2:width
  97           *got-height* v4l2:height)
  98     (format t "got ~Dx~D size ~D, format ~S~%"
  99             v4l2:width v4l2:height
 100             v4l2:sizeimage (format-string v4l2:pixelformat))
 101     (setq *camera-data* (make-array (* 4 *got-height* *got-width*)
 102                                     :element-type '(unsigned-byte 8)
 103                                     :initial-element #xff))))
 104
 105 (defun video-init (device)
 106   (let ((fd (isys:open device isys:o-rdwr)))
 107     (setq *capture-fd* fd)
 108     (diagnose fd)                                       ; info about device
 109     (device-init fd)                                    ; setup
 110     (let ((buffers (v4l2:map-buffers fd 4)))            ; map 4 buffers into memory
 111       (v4l2:stream-on fd buffers)                       ; start capturing
 112       (values fd buffers))))
 113
 114 (defun video-uninit (fd buffers)
 115   (v4l2:stream-off fd)                  ; stop capturing
 116   (v4l2:unmap-buffers buffers)          ; throw away buffers from memory
 117   (isys:close fd)                               ; close device
 118   (format t "that's all!~%"))
 119
 120 (defun capture-thread ()
 121   (format t "cap thread start~%")
 122   (multiple-value-bind (fd buffers)
 123       (video-init *capture-device*)
 124     (loop thereis *cap-thread-stop* do
 125          (let ((frame (without-errors (v4l2:get-frame fd))))            ; get one frame from driver
 126            (when frame                  ; errors from v4l2convert.so are highly possible
 127              (multiple-value-bind (buffer address)
 128                  (values-list (nth frame buffers))
 129                (declare (ignore buffer))
 130                ;; Silly rgb24->rgb32 converter
 131                (bt:with-lock-held (*camera-data-lock*)
 132                  (declare (optimize (speed 3) (debug 0) (safety 0)))
 133                  (loop for i fixnum from 0 below (* *got-width* *got-height*) do
 134                       (let ((r (cffi:mem-aref address :uchar (+ (* 3 i) 0)))
 135                             (g (cffi:mem-aref address :uchar (+ (* 3 i) 1)))
 136                             (b (cffi:mem-aref address :uchar (+ (* 3 i) 2))))
 137
 138                         (setf (aref *camera-data* (+ (* 4 i) 0)) r
 139                               (aref *camera-data* (+ (* 4 i) 1)) g
 140                               (aref *camera-data* (+ (* 4 i) 2)) b)))))
 141
 142              (when *camera-widget*
 143                (with-main-loop
 144                    (widget-queue-draw *camera-widget*)))
 145
 146              (v4l2:put-frame fd frame))))       ; put frame back to driver
 147     (video-uninit fd buffers))
 148   (format t "cap thread exit~%"))
 149
 150 (defun camera-init (widget)
 151   (declare (ignore widget))
 152   (gl:clear-color 0.8 0.8 0.8 0.8)
 153   (gl:enable :texture-rectangle-arb :depth-test)
 154   (gl:depth-func :lequal)
 155
 156   (gl:bind-texture :texture-rectangle-arb 0)
 157
 158   (gl:tex-image-2d :texture-rectangle-arb
 159                    0
 160                    :rgb8
 161                    *got-width*
 162                    *got-height*
 163                    0
 164                    :rgba
 165                    :unsigned-byte
 166                    *camera-data*)
 167
 168   (gl:new-list 1 :compile)
 169
 170   (gl:begin :quads)
 171   (gl:tex-coord 0 *got-height*)
 172   (gl:vertex 0.0 0.0)
 173   (gl:tex-coord 0 0)
 174   (gl:vertex 0.0 1.0)
 175   (gl:tex-coord *got-width* 0)
 176   (gl:vertex 1.0 1.0)
 177   (gl:tex-coord *got-width* *got-height*)
 178   (gl:vertex 1.0 0.0)
 179   (gl:end)
 180   (gl:end-list)
 181
 182   (gl:clear-depth 1.0)
 183   (gl:flush))
 184
 185 (defun camera-draw (widget event)
 186   (declare (ignore widget event))
 187   (gl:clear :color-buffer-bit :depth-buffer-bit)
 188   (gl:bind-texture :texture-rectangle-arb 0)
 189
 190   (when *camera-data*
 191     (bt:with-lock-held (*camera-data-lock*)
 192       (gl:tex-sub-image-2d :texture-rectangle-arb 0
 193                            0 0
 194                            *got-width*
 195                            *got-height*
 196                            :rgba
 197                            :unsigned-byte
 198                            *camera-data*)))
 199
 200   ;; Keep ratio 4:3
 201   (multiple-value-bind (w h)
 202       (gdk:drawable-get-size (widget-window widget))
 203     (let ((w1 w)
 204           (h1 h))
 205       (when (and (> w 0) (> h 0))
 206         (if (> (/ w h) 4/3)
 207             (setq h1 h
 208                   w1 (* h 4/3))
 209             (setq w1 w
 210                   h1 (* w 3/4))))
 211       (gl:viewport 0 0 w1 h1)))
 212
 213   (gl:matrix-mode :projection)
 214   (gl:load-identity)
 215   (glu:perspective 19.0 1.0 1.0 10.0)
 216
 217   (gl:matrix-mode :modelview)
 218   (gl:load-identity)
 219   (glu:look-at 0.0 0.0 3.0
 220                0.0 0.0 0.0
 221                0.0 1.0 0.0)
 222
 223   (gl:translate -0.5 -0.5 0.0)
 224
 225   (gl:call-list 1)
 226   (gl:flush))
 227
 228 (defun test ()
 229   (let ((cap-thread (bt:make-thread #'capture-thread :name "capturer")))
 230     (with-main-loop
 231       (let ((window (make-instance 'gtk-window
 232                                    :type :toplevel
 233                                    :window-position :center
 234                                    :title "Hello world!"
 235                                    :default-width *want-width*
 236                                    :default-height *want-height*))
 237             (hbox (make-instance 'h-box))
 238             (vbox (make-instance 'v-box))
 239             (quit-button (make-instance 'button :label "Quit"))
 240             (bright-spin (make-instance 'spin-button :label "Brightness"
 241                                         :adjustment (make-instance 'adjustment
 242                                                                    :lower 0d0
 243                                                                    :upper 100d0
 244                                                                    :step-increment 1d0))))
 245
 246
 247         (gobject:connect-signal bright-spin "value-changed"
 248                                 (lambda (widget)
 249                                   (let ((value (adjustment-value (spin-button-adjustment bright-spin))))
 250                                     (format t "~A changed value to ~F~%" widget value)
 251                                     (unless (without-errors
 252                                                 (format t "Previous value was: ~F~%"
 253                                                         (v4l2:get-control *capture-fd* v4l2:cid-brightness))
 254                                               (v4l2:set-control *capture-fd* v4l2:cid-brightness (/ value 100)))
 255                                       (v4l2:set-control *capture-fd* v4l2:cid-exposure (/ value 100))))))
 256
 257         (gobject:connect-signal quit-button "clicked"
 258                                 (lambda (widget)
 259                                   (declare (ignore widget))
 260                                   (bt:condition-notify *render-thread-stop*)))
 261
 262         (gobject:connect-signal window "destroy"
 263                                 (lambda (widget)
 264                                   (declare (ignore widget))
 265                                   (bt:condition-notify *render-thread-stop*)))
 266
 267 ;; Capture process needs to know which widget to ask for redraw
 268         (setq *camera-widget* (make-instance 'gl-drawing-area
 269                                              :on-init #'camera-init
 270                                              :on-expose #'camera-draw))
 271         (box-pack-start hbox vbox :expand nil)
 272         (box-pack-start hbox *camera-widget* :expand t)
 273         (box-pack-start vbox quit-button :expand nil)
 274         (box-pack-start vbox bright-spin :expand nil)
 275         (container-add window hbox)
 276         (widget-show window :all t)))
 277
 278 ;; Wait for window destruction
 279     (bt:with-lock-held (*render-thread-lock*)
 280       (bt:condition-wait *render-thread-stop* *render-thread-lock*))
 281     (setq *cap-thread-stop* t)
 282     (bt:join-thread cap-thread)))
 283
 284 (test)