example.lisp

   1 ;(require :cl-v4l2)
   2 (asdf:oos 'asdf:load-op :cl-v4l2)
   3 (asdf:oos 'asdf:load-op :clx)
   4
   5 (in-package :cl-v4l2)
   6
   7 (defmacro without-errors (&body body)
   8   `(handler-case ,@body
   9      (error ())))
  10
  11 (defun char-at (pos data)
  12   (code-char (ldb (byte 8 (* 8 pos)) data)))
  13
  14 (defun diagnose (fd)
  15   (let ((caps (v4l2-query-capabilities fd)))
  16     (format t (v4l2-%device-info caps))
  17     (unless (v4l2-capable caps cap-video-capture)
  18       (error "not a capture device"))
  19     (unless (v4l2-capable caps cap-streaming)
  20       (error "not a streaming device"))
  21     (when (v4l2-capable caps cap-tuner)
  22       (without-errors
  23         (loop for idx from 0 do
  24              (progn
  25                (v4l2-get-tuner-params fd idx)
  26                ;; show tuner params
  27                ))))
  28
  29     (without-errors
  30       (loop for idx from 0 do
  31            (with-wrapped-slots (index name type tuner) (v4l2-get-input-params fd idx) v4l2-input
  32              (format t "input [~D] name: ~A, type ~A~%"
  33                      index
  34                      name
  35                      (if (= type v4l2-input-type-tuner) "tuner" "camera"))
  36              (when (= type v4l2-input-type-tuner)
  37                (format t "input [~D] connected to tuner ~D~%" index tuner))
  38
  39              (without-errors
  40                (loop for idx1 from 0 do
  41                     (with-wrapped-slots (index name) (v4l2-get-input-standard fd idx1) v4l2-standard
  42                       (format t "input [~D] std [~D] name: ~A~%"
  43                               idx index name)))))))
  44
  45     (v4l2-set-input fd 0)               ; some cameras don't set input by default
  46
  47     (without-errors
  48       (loop for idx from 0 do
  49            (with-wrapped-slots (index pixelformat) (v4l2-get-format fd idx) v4l2-fmtdesc
  50              (format t "format [~D] ~A~A~A~A~%" index
  51                      (char-at 0 pixelformat)
  52                      (char-at 1 pixelformat)
  53                      (char-at 2 pixelformat)
  54                      (char-at 3 pixelformat)))))))
  55
  56 (defparameter got-width 0)
  57 (defparameter got-height 0)
  58 (defvar want-width 176);352)
  59 (defvar want-height 144);288)
  60
  61 (defun device-init (fd)
  62   (v4l2-set-input fd 0)
  63   (v4l2-set-control fd cid-exposure 0.05)
  64   (with-wrapped-slots (width height)
  65     (v4l2-format-pix (v4l2-set-image-format fd want-width want-height pix-fmt-rgb24)) v4l2-pix-format
  66     (setf got-width width
  67           got-height height))
  68   (format t "got ~Dx~D~%" got-width got-height))
  69
  70 ;; Typical session:
  71
  72 (defun test ()
  73   (let ((fd (%sys-open "/dev/video0" o-rdwr))
  74         buffers frame)
  75     (diagnose fd)                               ; what is at video0
  76     (device-init fd)                            ; setup
  77     (setq buffers (v4l2-map-buffers fd 2))      ; map 2 buffers into memory
  78     (v4l2-stream-on fd buffers)                 ; start capturing
  79
  80   (let* ((display (xlib:open-display ""))
  81          (screen (first (xlib:display-roots display)))
  82          (root-window (xlib:screen-root screen))
  83          (camera-window (xlib:create-window
  84                          :parent root-window
  85                          :x 50
  86                          :y 50
  87                          :width got-width
  88                          :height got-height
  89                          :background #x0000ff
  90                          :event-mask (xlib:make-event-mask :exposure
  91                                                            :enter-window)))
  92          (camera-window-gc (xlib:create-gcontext :foreground #x00ff00
  93                                                  :drawable camera-window)))
  94
  95     (xlib:map-window camera-window)
  96     (let* ((dbuf (xlib:create-pixmap :width got-width
  97                                      :height got-height
  98                                      :depth 24
  99                                      :drawable camera-window))
 100            (gc (xlib:create-gcontext :drawable dbuf))
 101            (data (make-array (* got-width got-height 4)
 102                              :element-type '(unsigned-byte 8)
 103                              :initial-element #x80)))
 104
 105     (loop for i from 0 #|below 10|# do          ; capture 10 frames
 106          (setq frame (v4l2-get-frame fd))       ; get one frame from driver
 107          (multiple-value-bind (buffer address length)
 108              (values-list (nth frame buffers))
 109            (loop for i from 0 below (* got-width got-height) do
 110                 (setf (aref data (+ (* 4 i) 0)) (mem-aref address :uchar (+ (* 3 i) 2))
 111                       (aref data (+ (* 4 i) 1)) (mem-aref address :uchar (+ (* 3 i) 1))
 112                       (aref data (+ (* 4 i) 2)) (mem-aref address :uchar (+ (* 3 i) 0))))
 113
 114            (xlib:put-raw-image dbuf gc data
 115                                :depth 24
 116                                :x 0 :y 0
 117                                :width got-width
 118                                :height got-height
 119                                :format :z-pixmap))
 120          (xlib:copy-area dbuf camera-window-gc 0 0
 121                          got-width got-height camera-window  0 0)
 122          (xlib:display-finish-output display)
 123
 124          (v4l2-put-frame fd frame))             ; put frame back to driver
 125
 126     (xlib:destroy-window camera-window)
 127     (xlib:free-gcontext camera-window-gc)
 128     (xlib:free-gcontext gc)
 129     (xlib:free-pixmap dbuf)
 130     (xlib:destroy-window camera-window)
 131
 132     (xlib:close-display display)))
 133
 134
 135     (v4l2-stream-off fd)                        ; stop capturing
 136     (v4l2-unmap-buffers buffers)                ; throw away buffers from memory
 137     (%sys-close fd)                             ; close device
 138     (format t "that's all!~%")))
 139
 140 (test)
 141
 142 ;; (%sys-open "/dev/video0" o-rdwr)
 143 ;; (diagnose 4)
 144 ;; (device-init 4)
 145 ;; (setq a (v4l2-map-buffers 4 4))
 146 ;; (v4l2-stream-on 4 a)
 147 ;; (v4l2-get-frame 4)
 148 ;; (v4l2-put-frame 4 0)
 149 ;; (v4l2-stream-off 4 a)
 150 ;; (v4l2-unmap-buffers a)
 151 ;; (%sys-close 4)