-
Notifications
You must be signed in to change notification settings - Fork 0
/
helpers.lisp
225 lines (198 loc) · 6.92 KB
/
helpers.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
(in-package :viseq)
(defconstant +window-freeratio+ #x00000100)
(defconstant +window-gui-normal+ #x00000010)
(defvar *cvfont* (cffi:foreign-alloc :pointer))
(defvar *cvfont-p* (cv:init-font *cvfont* cv:+font-hershey-simplex+ 1f0 1f0))
(defun update-font (&optional (hscale 1f0) (vscale 1f0))
(cv:init-font *cvfont* cv:+font-hershey-simplex+ hscale vscale))
(defmacro with-captured-file ((capture filename) &body body)
`(let ((,capture (cv:create-file-capture ,filename)))
(unwind-protect (progn ,@body)
(cv:release-capture ,capture))))
(defmacro with-captured-files (captures &body body)
(let ((vars (mapcar #'car captures)))
`(let ,(mapcar (lambda (x) `(,(car x) (cv:create-file-capture ,@(cdr x))))
captures)
(unwind-protect (progn ,@body)
,@(mapcar (lambda (x) `(cv:release-capture ,x))
vars)))))
(defmacro with-mem-storage ((mem-storage) &body body)
`(let ((,mem-storage (cv:create-mem-storage)))
(unwind-protect (progn ,@body)
(cv:release-mem-storage ,mem-storage))))
;; (defmacro with-gui-thread (&body body)
;; "Wraps BODY in code which masks float traps.
;; This is needed in SBCL on OSX because native code often
;; generate :inexact traps and land you in the debugger.
;; For non SBCL this wraps body in a progn."
;; `(trivial-main-thread:call-in-main-thread
;; (lambda ()
;; #+sbcl (sb-int:with-float-traps-masked (:invalid :divide-by-zero :overflow)
;; ,@body)
;; #+ccl (unwind-protect (progn
;; (ccl:set-fpu-mode :invalid nil)
;; ,@body)
;; (ccl:set-fpu-mode :invalid t))
;; #-(or sbcl ccl)
;; ,@body)))
;;--------------------------------------------------
(defun skip-to (capture frame)
"skip video capture to seconds"
(declare (optimize (speed 3))
(type cffi:foreign-pointer capture)
(type fixnum frame))
(cv:set-capture-property
capture
cv:+cap-prop-pos-frame+
frame)
NIL)
(defun current-pos (capture)
"current pos in seconds"
(* 1000f0
(cv:get-capture-property
capture
cv:+cap-prop-pos-msec+)))
(defun make-point (l)
"cv:point wrapper from l"
(let* ((x (car l))
(y (cadr l))
(point (cv:point x y)))
point))
;;--------------------------------------------------
(defun make-tri ()
(list (cv:point2d-32f 0 0)
(cv:point2d-32f 0 0)
(cv:point2d-32f 0 0)))
(defun make-quad ()
(list (cv:point2d-32f 0 0)
(cv:point2d-32f 0 0)
(cv:point2d-32f 0 0)
(cv:point2d-32f 0 0)))
;;--------------------------------------------------
(defun make-line (img x1 y1 x2 y2
&key (blue 0) (green 0) (red 0))
"cv:line wrapper"
(declare (type integer x1 y1 x2 y2 blue green red))
(cv:line img
(cv:point x1 y1)
(cv:point x2 y2)
(cv:scalar blue green red)))
(defun make-circle (img x y radius
&key (blue 0) (green 0) (red 0))
"cv:circle wrapper"
(declare (type integer x y radius blue green red))
(cv:circle img
(cv:point x y)
radius
(cv:scalar blue green red)))
(defun make-ellipse (img x y width height angle
&key (start-angle 360) (end-angle 0)
(blue 0) (green 0) (red 0))
"cv:ellipse wrapper"
(declare (type integer x y width height
angle start-angle end-angle
blue green red))
(cv:ellipse img
(cv:point x y)
(cv:size width height)
angle
start-angle
end-angle
(cv:scalar blue green red 255)))
(defun make-rectangle
(img x1 y1 x2 y2 &key (blue 0) (green 0) (red 0))
"cv:rectangle wrapper"
(declare (type integer x1 y1 x2 y2 blue green red))
(cv:rectangle img
(cv:point x1 y1) (cv:point x2 y2)
(cv:scalar blue green red)))
(defun draw-text (img text x y &key (red 0) (green 0) (blue 0))
"cv:put-text wrapper"
(declare (type fixnum red green blue x y)
(type string text)
(optimize speed (debug 0) (safety 0)))
(cv:put-text img
text
(cv:point x y)
*cvfont*
(cv:scalar red green blue)))
;;--------------------------------------------------
(defstruct cprops
nframes
fps
seconds
size
width
height)
(defun get-props (capture)
(declare (cffi:foreign-pointer capture))
"get all possible values from capture, for convenience"
(let* ((nframes (round (cv:get-capture-property
capture
cv:+cap-prop-frame-count+)))
(fps (cv:get-capture-property
capture
cv:+cap-prop-fps+))
(seconds (/ nframes fps))
(frame (cv:query-frame capture))
(size (cv:get-size frame))
(width (cv:width size))
(height (cv:height size)))
(make-cprops :nframes nframes
:fps fps
:seconds seconds
:size size
:height height :width width)))
(defun print-struct (struct)
(declare (type cprops struct))
(format t "~a~&" struct))
;;--------------------------------------------------
(defun 2d-rotate
(mat center-x center-y &optional (angle 0f0) (scale 1f0))
(declare (type cffi:foreign-pointer mat)
(type integer center-x center-y)
(type float angle scale)
(optimize (speed 3)))
(cv:2d-rotation-matrix (cv:point2d-32f center-x center-y)
angle scale
mat))
(defun update-swank ()
(let ((connection (or swank::*emacs-connection*
(swank::default-connection))))
(when connection
(swank::handle-requests connection t))))
;; FIXME
(defun get-frame
(capture
&optional (restart-frame 0) (stop-frame most-positive-fixnum)
(skip-to-frame 0))
(declare (type cffi:foreign-pointer capture)
(type fixnum stop-frame restart-frame skip-to-frame)
(optimize (speed 3) (safety 0) (debug 0)))
(let* ((current-frame
(the double-float
(cv:get-capture-property capture cv:+cap-prop-pos-frame+)))
(frame
(cond
((> current-frame stop-frame)
(skip-to capture restart-frame)
(cv:query-frame capture))
((= 0 skip-to-frame)
(cv:query-frame capture))
(t
(skip-to capture skip-to-frame)
(cv:query-frame capture)))))
(if (cffi:null-pointer-p frame)
(progn
(skip-to capture restart-frame)
(cv:query-frame capture))
frame)))
(defvar *capture-index* 0)
(defun get-frame-captures (&rest captures)
(let* ((capture (nth *capture-index* captures))
(frame (cv:query-frame capture)))
(if (cffi:null-pointer-p frame)
(progn
(skip-to capture 0)
(cv:query-frame capture))
frame)))