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
)
9 (:import-from
:iolib.syscalls %sys-open %sys-close o-rdwr
))
11 (in-package :test-v4l2
)
13 (defvar *capture-device
* "/dev/video0")
14 (defparameter *capture-fd
* nil
)
16 ;; what we want from camera
17 (defvar *want-width
* 352)
18 (defvar *want-height
* 288)
21 (defparameter *got-width
* nil
)
22 (defparameter *got-height
* nil
)
24 (defparameter *camera-widget
* nil
)
25 (defparameter *camera-data
* nil
)
26 (defparameter *camera-data-lock
* (bt:make-lock
"Camera data lock"))
28 (defparameter *cap-thread-stop
* nil
)
30 (defparameter *render-thread-stop
* (bt:make-condition-variable
))
31 (defparameter *render-thread-lock
* (bt:make-lock
"Render thread lock"))
33 (defmacro without-errors
(&body body
)
34 `(handler-case (progn ,@body
)
35 (error (c) (format t
"suppressed error: ~A~%" c
) nil
)))
37 (defun char-at (pos data
)
38 (code-char (ldb (byte 8 (* 8 pos
)) data
)))
40 (defun format-string (pixfmt)
41 (format nil
"~C~C~C~C"
48 (let ((caps (v4l2:query-capabilities fd
)))
49 (format t
(v4l2:%device-info caps
))
50 (unless (v4l2:capable caps v4l2
:cap-video-capture
)
51 (error "not a capture device"))
52 (unless (v4l2:capable caps v4l2
:cap-streaming
)
53 (error "not a streaming device"))
54 (when (v4l2:capable caps v4l2
:cap-tuner
)
56 (loop for idx from
0 do
58 (v4l2:get-tuner-params fd idx
)
63 (loop for idx from
0 do
64 (with-slots (v4l2:index v4l2
:name v4l2
:type v4l2
:tuner
)
65 (v4l2:get-input-params fd idx
)
66 (format t
"input [~D] name: ~A, type ~A~%"
69 (if (= v4l2
:type v4l2
:input-type-tuner
) "tuner" "camera"))
70 (when (= v4l2
:type v4l2
:input-type-tuner
)
71 (format t
"input [~D] connected to tuner ~D~%" v4l2
:index v4l2
:tuner
))
74 (loop for idx1 from
0 do
75 (with-slots (v4l2:index v4l2
:name
)
76 (v4l2:get-input-standard fd idx1
)
77 (format t
"input [~D] std [~D] name: ~A~%"
78 idx v4l2
:index v4l2
:name
)))))))
80 (v4l2:set-input fd
0) ; some cameras don't set input by default
83 (loop for idx from
0 do
84 (with-slots (v4l2:index v4l2
:pixelformat
) (v4l2:get-format fd idx
)
85 (format t
"format [~D] ~S~%" v4l2
:index
86 (format-string v4l2
:pixelformat
)))))))
88 (defun device-init (fd)
91 (v4l2:set-control fd v4l2
:cid-exposure
0.05))
92 (format t
"set ~Dx~D, format ~S~%" *want-width
* *want-height
*
93 (format-string v4l2
:pix-fmt-rgb24
))
94 (v4l2:set-image-format fd
*want-width
* *want-height
* v4l2
:pix-fmt-rgb24
)
95 (with-slots (v4l2:width v4l2
:height v4l2
:sizeimage v4l2
:pixelformat
)
96 (v4l2:format-pix
(v4l2:get-image-format fd
))
97 (setf *got-width
* v4l2
:width
98 *got-height
* v4l2
:height
)
99 (format t
"got ~Dx~D size ~D, format ~S~%"
100 v4l2
:width v4l2
:height
101 v4l2
:sizeimage
(format-string v4l2
:pixelformat
))
102 (setq *camera-data
* (make-array (* 4 *got-height
* *got-width
*)
103 :element-type
'(unsigned-byte 8)
104 :initial-element
#xff
))))
106 (defun video-init (device)
107 (let ((fd (%sys-open device o-rdwr
)))
108 (setq *capture-fd
* fd
)
109 (diagnose fd
) ; info about device
110 (device-init fd
) ; setup
111 (let ((buffers (v4l2:map-buffers fd
4))) ; map 4 buffers into memory
112 (v4l2:stream-on fd buffers
) ; start capturing
113 (values fd buffers
))))
115 (defun video-uninit (fd buffers
)
116 (v4l2:stream-off fd
) ; stop capturing
117 (v4l2:unmap-buffers buffers
) ; throw away buffers from memory
118 (%sys-close fd
) ; close device
119 (format t
"that's all!~%"))
121 (defun capture-thread ()
122 (format t
"cap thread start~%")
123 (multiple-value-bind (fd buffers
)
124 (video-init *capture-device
*)
125 (loop thereis
*cap-thread-stop
* do
126 (let ((frame (without-errors (v4l2:get-frame fd
)))) ; get one frame from driver
127 (when frame
; errors from v4l2convert.so are highly possible
128 (multiple-value-bind (buffer address
)
129 (values-list (nth frame buffers
))
130 (declare (ignore buffer
))
131 ;; Silly rgb24->rgb32 converter
132 (bt:with-lock-held
(*camera-data-lock
*)
133 (declare (optimize (speed 3) (debug 0) (safety 0)))
134 (loop for i fixnum from
0 below
(* *got-width
* *got-height
*) do
135 (let ((r (cffi:mem-aref address
:uchar
(+ (* 3 i
) 0)))
136 (g (cffi:mem-aref address
:uchar
(+ (* 3 i
) 1)))
137 (b (cffi:mem-aref address
:uchar
(+ (* 3 i
) 2))))
139 (setf (aref *camera-data
* (+ (* 4 i
) 0)) r
140 (aref *camera-data
* (+ (* 4 i
) 1)) g
141 (aref *camera-data
* (+ (* 4 i
) 2)) b
)))))
143 (when *camera-widget
*
145 (widget-queue-draw *camera-widget
*)))
147 (v4l2:put-frame fd frame
)))) ; put frame back to driver
148 (video-uninit fd buffers
))
149 (format t
"cap thread exit~%"))
151 (defun camera-init (widget)
152 (declare (ignore widget
))
153 (gl:clear-color
0.8 0.8 0.8 0.8)
154 (gl:enable
:texture-rectangle-arb
:depth-test
)
155 (gl:depth-func
:lequal
)
157 (gl:bind-texture
:texture-rectangle-arb
0)
159 (gl:tex-image-2d
:texture-rectangle-arb
169 (gl:new-list
1 :compile
)
172 (gl:tex-coord
0 *got-height
*)
176 (gl:tex-coord
*got-width
* 0)
178 (gl:tex-coord
*got-width
* *got-height
*)
186 (defun camera-draw (widget event
)
187 (declare (ignore widget event
))
188 (gl:clear
:color-buffer-bit
:depth-buffer-bit
)
189 (gl:bind-texture
:texture-rectangle-arb
0)
192 (bt:with-lock-held
(*camera-data-lock
*)
193 (gl:tex-sub-image-2d
:texture-rectangle-arb
0
202 (multiple-value-bind (w h
)
203 (gdk:drawable-get-size
(widget-window widget
))
206 (when (and (> w
0) (> h
0))
212 (gl:viewport
0 0 w1 h1
)))
214 (gl:matrix-mode
:projection
)
216 (glu:perspective
19.0 1.0 1.0 10.0)
218 (gl:matrix-mode
:modelview
)
220 (glu:look-at
0.0 0.0 3.0
224 (gl:translate -
0.5 -
0.5 0.0)
230 (let ((cap-thread (bt:make-thread
#'capture-thread
:name
"capturer")))
232 (let ((window (make-instance 'gtk-window
234 :window-position
:center
235 :title
"Hello world!"
236 :default-width
*want-width
*
237 :default-height
*want-height
*))
238 (hbox (make-instance 'h-box
))
239 (vbox (make-instance 'v-box
))
240 (quit-button (make-instance 'button
:label
"Quit"))
241 (bright-spin (make-instance 'spin-button
:label
"Brightness"
242 :adjustment
(make-instance 'adjustment
245 :step-increment
1d0
))))
248 (gobject:connect-signal bright-spin
"value-changed"
250 (let ((value (adjustment-value (spin-button-adjustment bright-spin
))))
251 (format t
"~A changed value to ~F~%" widget value
)
252 (unless (without-errors
253 (format t
"Previous value was: ~F~%"
254 (v4l2:get-control
*capture-fd
* v4l2
:cid-brightness
))
255 (v4l2:set-control
*capture-fd
* v4l2
:cid-brightness
(/ value
100)))
256 (v4l2:set-control
*capture-fd
* v4l2
:cid-exposure
(/ value
100))))))
258 (gobject:connect-signal quit-button
"clicked"
260 (declare (ignore widget
))
261 (bt:condition-notify
*render-thread-stop
*)))
263 (gobject:connect-signal window
"destroy"
265 (declare (ignore widget
))
266 (bt:condition-notify
*render-thread-stop
*)))
268 ;; Capture process needs to know which widget to ask for redraw
269 (setq *camera-widget
* (make-instance 'gl-drawing-area
270 :on-init
#'camera-init
271 :on-expose
#'camera-draw
))
272 (box-pack-start hbox vbox
:expand nil
)
273 (box-pack-start hbox
*camera-widget
* :expand t
)
274 (box-pack-start vbox quit-button
:expand nil
)
275 (box-pack-start vbox bright-spin
:expand nil
)
276 (container-add window hbox
)
277 (widget-show window
:all t
)))
279 ;; Wait for window destruction
280 (bt:with-lock-held
(*render-thread-lock
*)
281 (bt:condition-wait
*render-thread-stop
* *render-thread-lock
*))
282 (setq *cap-thread-stop
* t
)
283 (bt:join-thread cap-thread
)))