1 ;; $ LD_PRELOAD=/usr/lib64/libv4l/v4l2convert.so sbcl --load example.lisp
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
)
8 (:use
:common-lisp
:gtk
:gtkglext
))
10 (in-package :test-v4l2
)
12 (defvar *capture-device
* "/dev/video0")
13 (defparameter *capture-fd
* nil
)
15 ;; what we want from camera
16 (defvar *want-width
* 352)
17 (defvar *want-height
* 288)
20 (defparameter *got-width
* nil
)
21 (defparameter *got-height
* nil
)
23 (defparameter *camera-widget
* nil
)
24 (defparameter *camera-data
* nil
)
25 (defparameter *camera-data-lock
* (bt:make-lock
"Camera data lock"))
27 (defparameter *cap-thread-stop
* nil
)
29 (defparameter *render-thread-stop
* (bt:make-condition-variable
))
30 (defparameter *render-thread-lock
* (bt:make-lock
"Render thread lock"))
32 (defmacro without-errors
(&body body
)
33 `(handler-case (progn ,@body
)
34 (error (c) (format t
"suppressed error: ~A~%" c
) nil
)))
36 (defun char-at (pos data
)
37 (code-char (ldb (byte 8 (* 8 pos
)) data
)))
39 (defun format-string (pixfmt)
40 (format nil
"~C~C~C~C"
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
)
55 (loop for idx from
0 do
57 (v4l2:get-tuner-params fd idx
)
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~%"
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
))
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
)))))))
79 (v4l2:set-input fd
0) ; some cameras don't set input by default
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
)))))))
87 (defun device-init (fd)
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
))))
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
))))
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!~%"))
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))))
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
)))))
142 (when *camera-widget
*
144 (widget-queue-draw *camera-widget
*)))
146 (v4l2:put-frame fd frame
)))) ; put frame back to driver
147 (video-uninit fd buffers
))
148 (format t
"cap thread exit~%"))
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
)
156 (gl:bind-texture
:texture-rectangle-arb
0)
158 (gl:tex-image-2d
:texture-rectangle-arb
168 (gl:new-list
1 :compile
)
171 (gl:tex-coord
0 *got-height
*)
175 (gl:tex-coord
*got-width
* 0)
177 (gl:tex-coord
*got-width
* *got-height
*)
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)
191 (bt:with-lock-held
(*camera-data-lock
*)
192 (gl:tex-sub-image-2d
:texture-rectangle-arb
0
201 (multiple-value-bind (w h
)
202 (gdk:drawable-get-size
(widget-window widget
))
205 (when (and (> w
0) (> h
0))
211 (gl:viewport
0 0 w1 h1
)))
213 (gl:matrix-mode
:projection
)
215 (glu:perspective
19.0 1.0 1.0 10.0)
217 (gl:matrix-mode
:modelview
)
219 (glu:look-at
0.0 0.0 3.0
223 (gl:translate -
0.5 -
0.5 0.0)
229 (let ((cap-thread (bt:make-thread
#'capture-thread
:name
"capturer")))
231 (let ((window (make-instance 'gtk-window
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
244 :step-increment
1d0
))))
247 (gobject:connect-signal bright-spin
"value-changed"
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))))))
257 (gobject:connect-signal quit-button
"clicked"
259 (declare (ignore widget
))
260 (bt:condition-notify
*render-thread-stop
*)))
262 (gobject:connect-signal window
"destroy"
264 (declare (ignore widget
))
265 (bt:condition-notify
*render-thread-stop
*)))
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
)))
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
)))