New example.
authorVitaly Mayatskikh <v.mayatskih@gmail.com>
Sun, 23 Aug 2009 10:21:18 +0000 (23 12:21 +0200)
committerVitaly Mayatskikh <v.mayatskih@gmail.com>
Sun, 23 Aug 2009 10:21:18 +0000 (23 12:21 +0200)
CLX has bug preventing usage of relatively large images in XPutImage.
UI toolkit in example has been switched to CL-GTK2 and uses GtkGLExt
extension to raster image with help of OpenGL.

example.lisp

dissimilarity index 91%
index 1fa54e7..5c34229 100644 (file)
-;(require :cl-v4l2)
-(asdf:oos 'asdf:load-op :cl-v4l2)
-(asdf:oos 'asdf:load-op :clx)
-
-(in-package :cl-v4l2)
-
-(defmacro without-errors (&body body)
-  `(handler-case ,@body
-     (error ())))
-
-(defun char-at (pos data)
-  (code-char (ldb (byte 8 (* 8 pos)) data)))
-
-(defun diagnose (fd)
-  (let ((caps (v4l2-query-capabilities fd)))
-    (format t (v4l2-%device-info caps))
-    (unless (v4l2-capable caps cap-video-capture)
-      (error "not a capture device"))
-    (unless (v4l2-capable caps cap-streaming)
-      (error "not a streaming device"))
-    (when (v4l2-capable caps cap-tuner)
-      (without-errors
-       (loop for idx from 0 do
-            (progn
-              (v4l2-get-tuner-params fd idx)
-              ;; show tuner params
-              ))))
-
-    (without-errors
-      (loop for idx from 0 do
-          (with-wrapped-slots (index name type tuner) (v4l2-get-input-params fd idx) v4l2-input
-            (format t "input [~D] name: ~A, type ~A~%"
-                    index
-                    name
-                    (if (= type v4l2-input-type-tuner) "tuner" "camera"))
-            (when (= type v4l2-input-type-tuner)
-              (format t "input [~D] connected to tuner ~D~%" index tuner))
-
-            (without-errors
-              (loop for idx1 from 0 do
-                   (with-wrapped-slots (index name) (v4l2-get-input-standard fd idx1) v4l2-standard
-                     (format t "input [~D] std [~D] name: ~A~%"
-                             idx index name)))))))
-
-    (v4l2-set-input fd 0)              ; some cameras don't set input by default
-
-    (without-errors
-      (loop for idx from 0 do
-          (with-wrapped-slots (index pixelformat) (v4l2-get-format fd idx) v4l2-fmtdesc
-            (format t "format [~D] ~A~A~A~A~%" index
-                    (char-at 0 pixelformat)
-                    (char-at 1 pixelformat)
-                    (char-at 2 pixelformat)
-                    (char-at 3 pixelformat)))))))
-
-(defparameter got-width 0)
-(defparameter got-height 0)
-(defvar want-width 176);352)
-(defvar want-height 144);288)
-
-(defun device-init (fd)
-  (v4l2-set-input fd 0)
-  (v4l2-set-control fd cid-exposure 0.05)
-  (with-wrapped-slots (width height)
-    (v4l2-format-pix (v4l2-set-image-format fd want-width want-height pix-fmt-rgb24)) v4l2-pix-format
-    (setf got-width width
-         got-height height))
-  (format t "got ~Dx~D~%" got-width got-height))
-
-;; Typical session:
-
-(defun test ()
-  (let ((fd (%sys-open "/dev/video0" o-rdwr))
-       buffers frame)
-    (diagnose fd)                              ; what is at video0
-    (device-init fd)                           ; setup
-    (setq buffers (v4l2-map-buffers fd 2))     ; map 2 buffers into memory
-    (v4l2-stream-on fd buffers)                        ; start capturing
-
-  (let* ((display (xlib:open-display ""))
-        (screen (first (xlib:display-roots display)))
-        (root-window (xlib:screen-root screen))
-        (camera-window (xlib:create-window
-                        :parent root-window
-                        :x 50
-                        :y 50
-                        :width got-width
-                        :height got-height
-                        :background #x0000ff
-                        :event-mask (xlib:make-event-mask :exposure
-                                                          :enter-window)))
-        (camera-window-gc (xlib:create-gcontext :foreground #x00ff00
-                                                :drawable camera-window)))
-
-    (xlib:map-window camera-window)
-    (let* ((dbuf (xlib:create-pixmap :width got-width
-                                    :height got-height
-                                    :depth 24
-                                    :drawable camera-window))
-          (gc (xlib:create-gcontext :drawable dbuf))
-          (data (make-array (* got-width got-height 4)
-                            :element-type '(unsigned-byte 8)
-                            :initial-element #x80)))
-
-    (loop for i from 0 #|below 10|# do         ; capture 10 frames
-        (setq frame (v4l2-get-frame fd))       ; get one frame from driver
-        (multiple-value-bind (buffer address length)
-            (values-list (nth frame buffers))
-          (loop for i from 0 below (* got-width got-height) do
-               (setf (aref data (+ (* 4 i) 0)) (mem-aref address :uchar (+ (* 3 i) 2))
-                     (aref data (+ (* 4 i) 1)) (mem-aref address :uchar (+ (* 3 i) 1))
-                     (aref data (+ (* 4 i) 2)) (mem-aref address :uchar (+ (* 3 i) 0))))
-
-          (xlib:put-raw-image dbuf gc data
-                              :depth 24
-                              :x 0 :y 0
-                              :width got-width
-                              :height got-height
-                              :format :z-pixmap))
-        (xlib:copy-area dbuf camera-window-gc 0 0
-                        got-width got-height camera-window  0 0)
-        (xlib:display-finish-output display)
-
-        (v4l2-put-frame fd frame))             ; put frame back to driver
-
-    (xlib:destroy-window camera-window)
-    (xlib:free-gcontext camera-window-gc)
-    (xlib:free-gcontext gc)
-    (xlib:free-pixmap dbuf)
-    (xlib:destroy-window camera-window)
-
-    (xlib:close-display display)))
-
-
-    (v4l2-stream-off fd)                       ; stop capturing
-    (v4l2-unmap-buffers buffers)               ; throw away buffers from memory
-    (%sys-close fd)                            ; close device
-    (format t "that's all!~%")))
-
-(test)
-
-;; (%sys-open "/dev/video0" o-rdwr)
-;; (diagnose 4)
-;; (device-init 4)
-;; (setq a (v4l2-map-buffers 4 4))
-;; (v4l2-stream-on 4 a)
-;; (v4l2-get-frame 4)
-;; (v4l2-put-frame 4 0)
-;; (v4l2-stream-off 4 a)
-;; (v4l2-unmap-buffers a)
-;; (%sys-close 4)
+;;
+;; CL-V4L2 example
+;;
+;; $ LD_PRELOAD=/usr/lib64/libv4l/v4l2convert.so sbcl --load example.lisp
+
+(asdf:oos 'asdf:load-op :cl-v4l2)
+(asdf:oos 'asdf:load-op :cl-gtk2-gtkglext)
+(asdf:oos 'asdf:load-op :bordeaux-threads)
+
+(defpackage :test-v4l2
+  (:use :common-lisp :gtk :gtkglext)
+  (:import-from :iolib.syscalls %sys-open %sys-close o-rdwr))
+
+(in-package :test-v4l2)
+
+(defvar *capture-device* "/dev/video1")
+(defvar *want-width* 640)
+(defvar *want-height* 480)
+(defparameter *got-width* nil)
+(defparameter *got-height* nil)
+
+(defparameter *camera-widget* nil)
+(defparameter *camera-data* nil)
+(defparameter *camera-data-lock* (bt:make-lock "Camera data lock"))
+
+(defparameter *cap-thread-stop* nil)
+
+(defparameter *render-thread-stop* (bt:make-condition-variable))
+(defparameter *render-thread-lock* (bt:make-lock "Render thread lock"))
+
+(defmacro without-errors (&body body)
+  `(handler-case ,@body
+     (error (c) (format t "suppressed error: ~A~%" c) nil)))
+
+(defun char-at (pos data)
+  (code-char (ldb (byte 8 (* 8 pos)) data)))
+
+(defun format-string (pixfmt)
+  (format nil "~C~C~C~C"
+         (char-at 0 pixfmt)
+         (char-at 1 pixfmt)
+         (char-at 2 pixfmt)
+         (char-at 3 pixfmt)))
+
+(defun diagnose (fd)
+  (let ((caps (v4l2:query-capabilities fd)))
+    (format t (v4l2:%device-info caps))
+    (unless (v4l2:capable caps v4l2:cap-video-capture)
+      (error "not a capture device"))
+    (unless (v4l2:capable caps v4l2:cap-streaming)
+      (error "not a streaming device"))
+    (when (v4l2:capable caps v4l2:cap-tuner)
+      (without-errors
+         (loop for idx from 0 do
+              (progn
+                (v4l2:get-tuner-params fd idx)
+                ;; show tuner params
+                ))))
+
+    (without-errors
+       (loop for idx from 0 do
+            (with-slots (v4l2:index v4l2:name v4l2:type v4l2:tuner)
+                (v4l2:get-input-params fd idx)
+              (format t "input [~D] name: ~A, type ~A~%"
+                      v4l2:index
+                      v4l2:name
+                      (if (= v4l2:type v4l2:input-type-tuner) "tuner" "camera"))
+              (when (= v4l2:type v4l2:input-type-tuner)
+                (format t "input [~D] connected to tuner ~D~%" v4l2:index v4l2:tuner))
+
+              (without-errors
+                  (loop for idx1 from 0 do
+                       (with-slots (v4l2:index v4l2:name)
+                           (v4l2:get-input-standard fd idx1)
+                         (format t "input [~D] std [~D] name: ~A~%"
+                                 idx v4l2:index v4l2:name)))))))
+
+    (v4l2:set-input fd 0)              ; some cameras don't set input by default
+
+    (without-errors
+       (loop for idx from 0 do
+            (with-slots (v4l2:index v4l2:pixelformat) (v4l2:get-format fd idx)
+              (format t "format [~D] ~S~%" v4l2:index
+                      (format-string v4l2:pixelformat)))))))
+
+(defun device-init (fd)
+  (v4l2:set-input fd 0)
+  (without-errors
+      (v4l2:set-control fd v4l2:cid-exposure 0.05))
+  (format t "set ~Dx~D, format ~S~%" *want-width* *want-height*
+         (format-string v4l2:pix-fmt-rgb24))
+  (v4l2:set-image-format fd *want-width* *want-height* v4l2:pix-fmt-rgb24)
+  (with-slots (v4l2:width v4l2:height v4l2:sizeimage v4l2:pixelformat)
+      (v4l2:format-pix (v4l2:get-image-format fd))
+    (setf *got-width* v4l2:width
+         *got-height* v4l2:height)
+    (format t "got ~Dx~D size ~D, format ~S~%"
+           v4l2:width v4l2:height
+           v4l2:sizeimage (format-string v4l2:pixelformat))
+    (setq *camera-data* (make-array (* 4 *got-height* *got-width*)
+                                   :element-type '(unsigned-byte 8)
+                                   :initial-element #xff))))
+
+(defun video-init (device)
+  (let ((fd (%sys-open device o-rdwr)))
+    (diagnose fd)                                      ; info about device
+    (device-init fd)                                   ; setup
+    (let ((buffers (v4l2:map-buffers fd 4)))           ; map 4 buffers into memory
+      (v4l2:stream-on fd buffers)                      ; start capturing
+      (values fd buffers))))
+
+(defun video-uninit (fd buffers)
+  (v4l2:stream-off fd)                 ; stop capturing
+  (v4l2:unmap-buffers buffers)         ; throw away buffers from memory
+  (%sys-close fd)                              ; close device
+  (format t "that's all!~%"))
+
+(defun capture-thread ()
+  (format t "cap thread start~%")
+  (multiple-value-bind (fd buffers)
+      (video-init *capture-device*)
+    (loop thereis *cap-thread-stop* do
+        (let ((frame (without-errors (v4l2:get-frame fd))))            ; get one frame from driver
+          (when frame                  ; errors from v4l2convert.so are highly possible
+            (multiple-value-bind (buffer address)
+                (values-list (nth frame buffers))
+              (declare (ignore buffer))
+              ;; Silly rgb24->rgb32 converter
+              (bt:with-lock-held (*camera-data-lock*)
+                (declare (optimize (speed 3) (debug 0) (safety 0)))
+                (loop for i fixnum from 0 below (* *got-width* *got-height*) do
+                     (setf (aref *camera-data* (+ (* 4 i) 0)) (cffi:mem-aref address :uchar (+ (* 3 i) 0))
+                           (aref *camera-data* (+ (* 4 i) 1)) (cffi:mem-aref address :uchar (+ (* 3 i) 1))
+                           (aref *camera-data* (+ (* 4 i) 2)) (cffi:mem-aref address :uchar (+ (* 3 i) 2))))))
+
+            (when *camera-widget*
+              (with-main-loop
+                (widget-queue-draw *camera-widget*)))
+
+            (v4l2:put-frame fd frame))))       ; put frame back to driver
+    (video-uninit fd buffers))
+  (format t "cap thread exit~%"))
+
+(defun camera-init (widget)
+  (declare (ignore widget))
+  (gl:clear-color 0.8 0.8 0.8 0.8)
+  (gl:enable :texture-rectangle-arb :depth-test)
+  (gl:depth-func :lequal)
+
+  (gl:bind-texture :texture-rectangle-arb 0)
+
+  (gl:tex-image-2d :texture-rectangle-arb
+                  0
+                  :rgb8
+                  *got-width*
+                  *got-height*
+                  0
+                  :rgba
+                  :unsigned-byte
+                  *camera-data*)
+
+  (gl:new-list 1 :compile)
+
+  (gl:begin :quads)
+  (gl:tex-coord 0 *got-height*)
+  (gl:vertex 0.0 0.0)
+  (gl:tex-coord 0 0)
+  (gl:vertex 0.0 1.0)
+  (gl:tex-coord *got-width* 0)
+  (gl:vertex 1.0 1.0)
+  (gl:tex-coord *got-width* *got-height*)
+  (gl:vertex 1.0 0.0)
+  (gl:end)
+  (gl:end-list)
+
+  (gl:clear-depth 1.0)
+  (gl:flush))
+
+(defun camera-draw (widget event)
+  (declare (ignore event))
+  (gl:clear :color-buffer-bit :depth-buffer-bit)
+  (gl:bind-texture :texture-rectangle-arb 0)
+
+  (when *camera-data*
+    (bt:with-lock-held (*camera-data-lock*)
+      (gl:tex-sub-image-2d :texture-rectangle-arb 0
+                          0 0
+                          *got-width*
+                          *got-height*
+                          :rgba
+                          :unsigned-byte
+                          *camera-data*)))
+
+  ;; Keep ratio 4:3
+  (multiple-value-bind (w h)
+      (gdk:drawable-get-size (widget-window widget))
+    (let ((w1 w)
+         (h1 h))
+      (when (and (> w 0) (> h 0))
+       (if (> (/ w h) 4/3)
+           (setq h1 h
+                 w1 (* h 4/3))
+           (setq w1 w
+                 h1 (* w 3/4))))
+      (gl:viewport 0 0 w1 h1)))
+
+  (gl:matrix-mode :projection)
+  (gl:load-identity)
+  (glu:perspective 19.0 1.0 1.0 10.0)
+
+  (gl:matrix-mode :modelview)
+  (gl:load-identity)
+  (glu:look-at 0.0 0.0 3.0
+              0.0 0.0 0.0
+              0.0 1.0 0.0)
+
+  (gl:translate -0.5 -0.5 0.0)
+
+  (gl:call-list 1)
+  (gl:flush))
+
+(defun test ()
+  (let ((cap-thread (bt:make-thread #'capture-thread :name "capturer")))
+    (with-main-loop
+      (let ((window (make-instance 'gtk-window
+                                  :type :toplevel
+                                  :window-position :center
+                                  :title "Hello world!"
+                                  :default-width *want-width*
+                                  :default-height *want-height*)))
+
+       (gobject:connect-signal window "destroy"
+                               (lambda (widget)
+                                 (declare (ignore widget))
+                                 (bt:condition-notify *render-thread-stop*)))
+
+;; Capture process needs to know which widget to ask for redraw
+       (setq *camera-widget* (make-instance 'gl-drawing-area
+                                            :on-init #'camera-init
+                                            :on-draw #'camera-draw))
+       (container-add window *camera-widget*)
+       (widget-show window :all t)))
+
+;; Wait for window destruction
+    (bt:with-lock-held (*render-thread-lock*)
+      (bt:condition-wait *render-thread-stop* *render-thread-lock*))
+    (setq *cap-thread-stop* t)
+    (bt:join-thread cap-thread)))
+
+(test)