-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathmatch.tin
457 lines (411 loc) · 21.8 KB
/
match.tin
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
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defnet match (th-main name1 name2 av1 av2 scd1 scd2 pix default-info)
(deflocal m scd-min-blocks scd-min-avg-block-size thres1 thres2 thres avg1 avg2 alternate i j)
(pix-wip pix)
(opt (gui-draw-image-th th-main))
(set scd-min-blocks (cfg-get-or-default-num "scd-min-blocks" default-info))
(set scd-min-avg-block-size (cfg-get-or-default-num "scd-min-avg-block-size" default-info))
(set m (match-create name1 name2 av1 av2 scd1 scd2 th-main pix default-info))
(set i (map-free1 m))
(map-report m)
(set avg1 (array-avg scd1))
(set avg2 (array-avg scd2))
(for alternate in [ false true ] do
(if alternate
then (msg-log m "\n\n\nstarting alternate strategies\n\n\n") )
(set thres (match-params m "init-scd-threshold"))
(while (>= thres (match-params m "min-scd-threshold")) do
(set thres1 (* avg1 thres))
(set thres2 (* avg2 thres))
(repeat (msg-log m (+ "begin match-step: " (approx3 thres1) "-" (approx3 thres2) nl))
(set j i)
(match-step false alternate false m thres1 thres2 scd-min-blocks scd-min-avg-block-size)
until (match-abort m)
(set i (map-free1 m))
(msg-log m (+ "end match-step: " (approx3 thres1) "-" (approx3 thres2) " -> " (- j i) nl))
until (= i j) )
until (match-abort m)
(set thres (* thres (match-params m "scd-threshold-ratio"))) )
until (match-abort m) )
(if (and (not (match-abort m)) (cfg-get-or-default "final-closure" default-info))
then (match-step false true true m thres1 thres2 scd-min-blocks scd-min-avg-block-size) )
(match-destroy m true) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defnet match-step (ignore-false alternate final-closure m thres1 thres2 scd-min-blocks scd-min-avg-block-size)
(deflocal u ut a1 a2 p1a p1b p2a p2b
best-p2 best-d1 best-d2 n mdb segfirst seglast bound )
(set u (map-undef1 m))
(while (> (length u) 0) do
(set ut (queue-get u))
(set segfirst (= <ut 0> 1))
(set seglast (= <ut 1> (map-max1 m)))
(set bound 0)
(set a1 (seq-threshold (match-scd1 m) <ut 0> <ut 1> thres1))
(set a2 (seq-threshold (match-scd2 m) <ut 2> <ut 3> thres2))
(set p1a 0)
(set p1b (- (length a1) 1))
(set p2a 0)
(set p2b (- (length a2) 1))
(while (and (<= p1a p1b) (not (match-abort m))) do
(alt (match-receivenb m)
(seq (match-best ignore-false a1 a2 p1a p1b p2a p2b best-p2 best-d1 best-d2 n)
(set mdb (/ n (max best-d1 best-d2)))
(>= mdb 8)
(or (and (>= (min best-d1 best-d2) scd-min-blocks)
(>= mdb scd-min-avg-block-size) )
(and (= p1a 0) (= best-p2 p2a) (not segfirst))
(and (> (+ p1a best-d1) p1b) (> (+ best-p2 best-d2) p2b) (not seglast)) )
(match-check-and-bind alternate m (cdr <a1 p1a>) (cdr <a2 best-p2>) n)
(inc bound n)
(inc p1a best-d1)
(set p2a (+ best-p2 best-d2)) )
(inc p1a) ))
(if (and alternate (= bound 0) (not (match-abort m)))
then (match-step-alternate final-closure m ut a1 a2 segfirst seglast) )))
(defnet match-step-alternate (final-closure m ut a1 a2 segfirst seglast)
(deflocal p1a p2a p1b p2b size1 size2 n n1 n2 score1 score2)
(set p1a <ut 0>)
(set p2a <ut 2>)
(set p1b (- (length a1) 1))
(set p2b (- (length a2) 1))
(set size1 (- <ut 1> p1a -1))
(set size2 (- <ut 3> p2a -1))
(set n (min size1 size2))
(set n1 (min (car <a1 0>) (car <a2 0>)))
(set n2 (min (car <a1 p1b>) (car <a2 p2b>)))
(alt (seq (= size1 size2)
(if final-closure
then (msg-log m (+ "\nfinal closure: ["
(int->str p1a 6 '0') "-" (int->str (+ p1a n -1) 6 '0')
"] <-> ["
(int->str p2a 6 '0') "-" (int->str (+ p2a n -1) 6 '0')
"] (" n ")" nl ))
(map-bind m p1a p2a n)
(map-report m)
else (match-check-and-bind true m p1a p2a n) ))
(truep (match-abort m))
(seq (not segfirst)
(not seglast)
; (> (+ n1 n2) n) ; si puo` fare meglio?
(match-check true m p1a p2a n1 score1)
(match-check true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2 score2)
(msg-log m (+ "conflicting strategies: " (approx3 score1) " vs " (approx3 score2) nl))
(if (>= (abs (- score1 score2)) 0.03)
then (msg-log m (+ "done" nl))
(if (> score1 score2)
then (match-check-and-bind true m p1a p2a n1)
else (match-check-and-bind true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2) )))
(truep (match-abort m))
(seq (not segfirst)
(match-check true m p1a p2a n1 score1)
(> score1 0)
(match-check-and-bind true m p1a p2a n1) )
(truep (match-abort m))
(seq (not seglast)
(match-check true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2 score2)
(> score2 0)
(match-check-and-bind true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2) )
(success) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defnet match-best (ignore-false a1 a2 p1 p1b p2a p2b @best-p2 @best-d1 @best-d2 @best-n)
(deflocal d1 d2 x1 x2 n i done ab1 ab2)
(set ab1 true)
(set ab2 true)
(set @best-d1 0)
(while (<= p2a p2b) do
(set d1 p1)
(set d2 p2a)
(set n 0)
(repeat (set x1 (car <a1 d1>))
(set x2 (car <a2 d2>))
(if (= x1 x2)
then (inc d1)
(inc d2)
(inc n x1)
(set done false)
else (if ignore-false
then (alt (seq (= ab1 true)
(match-best-ignore-false x1 a2 d2 p2b i)
(inc d1)
(inc d2 i)
(inc n x1)
(set ab2 false)
(set done false) )
(seq (= ab2 true)
(match-best-ignore-false x2 a1 d1 p1b i)
(inc d1 i)
(inc d2)
(inc n x2)
(set ab1 false)
(set done false) )
(set done true) )
else (set done true) ))
until done
until (> d1 p1b)
until (> d2 p2b) )
(inc d1 -p1)
(if (> d1 @best-d1)
then (set @best-p2 p2a)
(set @best-d1 d1)
(set @best-d2 (- d2 p2a))
(set @best-n n) )
(inc p2a) )
(> @best-d1 0) )
(defnet match-best-ignore-false (target a p1 p2 @n)
(deflocal sum)
(set sum 0)
(set @n 0)
(repeat (inc sum (car <a p1>))
(<= sum target)
(inc @n)
until (= sum target)
(< p1 p2)
(inc p1) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defnet match-check (alternate m p1 p2 n @score)
(deflocal step cnt score i j)
(set step (max 1 (/ (- n 1)
(- (+ (match-params m "checks-per-interval")
(if alternate (match-params m "checks-per-interval-extra") 0) )
1 ))))
(set @score 0)
(set cnt 0)
(set i 0)
(repeat (set j (rint i))
(sift-check alternate m (+ p1 j) (+ p2 j) score)
(if (> score 0)
then (inc cnt)
(inc @score score) )
until (= i (- n 1))
(inc i step) )
(if (> cnt 0)
then (set @score (/ @score cnt)) ))
(defnet match-check-and-bind (alternate m p1 p2 n)
(deflocal score)
(msg-log m (+ "\ninterval to check: ["
(int->str p1 6 '0') "-" (int->str (+ p1 n -1) 6 '0')
"] <-> ["
(int->str p2 6 '0') "-" (int->str (+ p2 n -1) 6 '0')
"] (" n ")" nl ))
(match-check alternate m p1 p2 n score)
(map-bind m p1 p2 n)
(map-report m)
(msg-log m (+ "\ninterval accepted: ["
(int->str p1 6 '0') "-" (int->str (+ p1 n -1) 6 '0')
"] <-> ["
(int->str p2 6 '0') "-" (int->str (+ p2 n -1) 6 '0')
"] (" n ")" nl )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun match-create (name1 name2 av1 av2 scd1 scd2 th-main pix default-info) net match-create)
(defnet match-create (name1 name2 av1 av2 scd1 scd2 th-main pix default-info @m)
(deflocal frm1 frm2 pix1 pix2 k params v)
(set params (assoc))
(for k in [ "init-scd-threshold"
"min-scd-threshold"
"scd-threshold-ratio"
"checks-per-interval"
"checks-per-interval-extra"
"min-keypoints"
"min-keypoints-min-ratio"
"min-keypoints-min-ratio-lum"
"sift-match-threshold-val"
"sift-match-threshold-min-ratio"
"sift-agreements-min"
"sift-proportionality-threshold"
"filter-gamma1"
"filter-gamma2"
] do
(set <params k> (cfg-get-or-default-num k default-info)) )
(for k in [ "filter-mirror1"
"filter-flip1"
"filter-mirror2"
"filter-flip2"
"sift-draw-lines"
] do
(set <params k> (cfg-get-or-default k default-info)) )
(set pix1 (cfg-get-or-default "sift-scale" default-info))
(set pix2 (cfg-get-or-default-num "sift-scale-pixels" default-info))
(set frm1 (match-create-frm 1 av1 pix1 pix2))
(set frm2 (match-create-frm 2 av2 pix1 pix2))
(set k (min (/ (- (width pix) (* 2 (space))) (max (width frm1) (width frm2)))
(/ (- (height pix) (* 3 (space))) (+ (height frm1) (height frm2))) ))
(set pix1 (pix-create (* k (width frm1)) (* k (height frm1))))
(set pix2 (pix-create (* k (width frm2)) (* k (height frm2))))
(set @m (array 26))
(set k (cfg-get (key-sck av1 av2 name1 name2)))
(if (<> k undef)
then (set <@m 0> <k 0>)
(set <@m 1> <k 1>)
(set <@m 6> <k 2>)
(set <@m 7> <k 3>)
(set <@m 8> <k 4>)
(set <@m 9> <k 5>)
(if (= (length k) 8)
then (set <@m 23> <k 6>)
(set <@m 24> <k 7>)
else ; FIXME qui andrebbero ricalcolate le luminosità
; dei frame che hanno un res intero
(set <@m 23> 0)
(set <@m 24> 0) )
else (set <@m 0> (assoc))
(set <@m 1> 0)
(set <@m 6> 0)
(set <@m 7> 0)
(set <@m 8> 0)
(set <@m 9> 0)
(set <@m 23> 0)
(set <@m 24> 0) )
(set <@m 2> av1)
(set <@m 3> av2)
(set <@m 4> frm1)
(set <@m 5> frm2)
(set <@m 10> (map-create (- (length scd1) 1) (- (length scd2) 1)))
(set <@m 11> th-main)
(set <@m 12> (thread-create (netptr th-sift-features)
(thread-self) frm1 ))
(set <@m 13> (thread-create (netptr th-sift-features)
(thread-self) frm2 ))
(set <@m 14> name1)
(set <@m 15> name2)
(set <@m 16> pix1)
(set <@m 17> pix2)
(set <@m 18> pix)
(set <@m 19> (array 0))
(set <@m 20> scd1)
(set <@m 21> scd2)
(set <@m 22> params)
(set <@m 25> false)
(set k (cfg-get (key-map av1 av2 name1 name2)))
(if (<> k undef)
then (for k in <k 2> do
(map-bind @m <k 0> <k 1> <k 2>) )))
(defun match-create-frm (which av sift-scale sift-scale-pixels) net match-create-frm)
(defnet match-create-frm (which av sift-scale sift-scale-pixels @frm)
(deflocal w h k)
(set w (* (width av) (my-av-par which av)))
(set h (height av))
(if sift-scale
then (set k (sqrt (/ (* w h) sift-scale-pixels)))
(set w (/ w k))
(set h (/ h k)) )
(set @frm (pix-create (rint w) (rint h))) )
(defnet match-destroy (m store)
(close (match-frm1 m) (match-frm2 m) (match-pix1 m) (match-pix2 m))
(if store
then (cfg-set (key-sck (match-av1 m) (match-av2 m)
(match-name1 m) (match-name2 m) )
(list (match-cache m) (match-passed m) <m 6> <m 7>
<m 8> <m 9> <m 23> <m 24> ))
(cfg-set (key-map (match-av1 m) (match-av2 m)
(match-name1 m) (match-name2 m) )
(list (- (length (match-scd1 m)) 1)
(- (length (match-scd2 m)) 1)
(match-map-step m) )))
(send undef to (match-th-sift1 m))
(send undef to (match-th-sift2 m))
(thread-join (match-th-sift1 m))
(thread-join (match-th-sift2 m))
(not (match-abort m)) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defnet match-receivenb (m)
(truep <_abort 0>)
(match-abort m) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun match-cache (m) <m 0>)
(defun match-passed (m) <m 1>)
(defun match-av1 (m) <m 2>)
(defun match-av2 (m) <m 3>)
(defun match-frm1 (m) <m 4>)
(defun match-frm2 (m) <m 5>)
(defun match-rx (m) (/ <m 7> <m 6>))
(defun match-ry (m) (/ <m 9> <m 8>))
(defun match-width1 (m) (width (match-av1 m)))
(defun match-height1 (m) (height (match-av1 m)))
(defun match-width2 (m) (width (match-av2 m)))
(defun match-height2 (m) (height (match-av2 m)))
(defun match-hcorrection (m)
(/ (/ (match-width2 m) (width (match-frm2 m)))
(/ (match-width1 m) (width (match-frm1 m))) ))
(defun match-vcorrection (m)
(/ (/ (match-height2 m) (height (match-frm2 m)))
(/ (match-height1 m) (height (match-frm1 m))) ))
(defun match-map (m) <m 10>)
(defun match-th-main (m) <m 11>)
(defun match-th-sift1 (m) <m 12>)
(defun match-th-sift2 (m) <m 13>)
(defun match-name1 (m) <m 14>)
(defun match-name2 (m) <m 15>)
(defun match-pix1 (m) <m 16>)
(defun match-pix2 (m) <m 17>)
(defun match-pix (m) <m 18>)
(defun match-map-step (m) <m 19>)
(defun match-scd1 (m) <m 20>)
(defun match-scd2 (m) <m 21>)
(defun match-params (m key) <m 22 key>)
(defun match-abort (m) <m 25>)
(defnet match-abort (m) (set <m 25> true))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;