├── License.txt ├── Makefile ├── README.md ├── audio.tin ├── cfg.tin ├── clear.tin ├── constants.tin ├── ffmatch.trp ├── force.tin ├── gui.tin ├── icons ├── emblem-videos.ico └── logo.png ├── info.tin ├── init.tin ├── lang.tin ├── map.tin ├── match.tin ├── move-scd.tin ├── move-slide.tin ├── move-spin.tin ├── move-sync.tin ├── open.tin ├── permute.tin ├── project.tin ├── scdscan.tin ├── sift.tin ├── sound.tin ├── threads.tin └── utils.tin /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: ffmatch 3 | 4 | clean: 5 | rm -f *~ *.c ffmatch ffmatch.exe ffmatch-compile.sh ffmatch.log ffmatch-icon.o 6 | 7 | install: all 8 | cp -f ffmatch /usr/local/bin 9 | 10 | ffmatch: ffmatch.trp init.tin lang.tin gui.tin move-sync.tin \ 11 | move-scd.tin move-spin.tin move-slide.tin force.tin cfg.tin \ 12 | utils.tin constants.tin scdscan.tin match.tin map.tin \ 13 | sift.tin audio.tin permute.tin threads.tin sound.tin \ 14 | clear.tin open.tin project.tin info.tin 15 | trpc -f ffmatch.trp 16 | 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FFmatch 2 | 3 | FFmatch is a program that helps to adapt audio tracks of different versions of a movie. 4 | -------------------------------------------------------------------------------- /clear.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet clear-db-vacuum-cb (self) 12 | (alt (seq (iup-progress 13 | (thread-create (netptr clear-db-vacuum-th) (thread-self)) 14 | self "Db vacuum..." true false false true true ) 15 | (sound-iup-info60 self "Db vacuum completed.") ) 16 | (sound-iup-error60 self "Error.") )) 17 | 18 | (defnet clear-db-vacuum-th (th) 19 | (deflocal res) 20 | 21 | (alt (seq (sqlite3-exec _db undef "VACUUM") 22 | (set res "q") ) 23 | (set res "a") ) 24 | (send res to th) ) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;;;; ;;;; 29 | ;;;; ;;;; 30 | ;;;; ;;;; 31 | ;;;; ;;;; 32 | ;;;; ;;;; 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (defnet clear-text1-cb (self) 37 | (clear-text-low 1) ) 38 | 39 | (defnet clear-text2-cb (self) 40 | (clear-text-low 2) ) 41 | 42 | (defnet clear-text-low (which) 43 | (iup-text-clear <_kv (+ "text" which)>) 44 | (gui-update) ) 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;;;; ;;;; 49 | ;;;; ;;;; 50 | ;;;; ;;;; 51 | ;;;; ;;;; 52 | ;;;; ;;;; 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | 56 | (defnet clear-paths-cb (self) 57 | (opt (clear-paths-low self)) ) 58 | 59 | (defnet clear-paths-low (self) 60 | (deflocal q l) 61 | 62 | (set q (queue)) 63 | (sqlite3-exec-data _db (netptr clear-paths-cback) q 64 | "SELECT path FROM paths" ) 65 | (set l (length q)) 66 | (if (= l 0) 67 | then (iup-info60 self $"There are no obsolete paths.") 68 | (fail) ) 69 | ;(print (sprintl q nl) nl) 70 | (iup-confirm60 self (sprint l ' ' (if (= l 1) $"obsolete path will be deleted." $"obsolete paths will be deleted.") nl 71 | $"Are you sure?" )) 72 | (sqlite3-exec _db undef 73 | "DELETE FROM paths WHERE path IN('" 74 | (sprintl q "','") "')" ) 75 | (gui-update) ) 76 | 77 | (defnet clear-paths-cback (q path) 78 | (if (not (pathexists path)) 79 | then (queue-put q (sqlite3-escape-strings path)) )) 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | ;;;; ;;;; 84 | ;;;; ;;;; 85 | ;;;; ;;;; 86 | ;;;; ;;;; 87 | ;;;; ;;;; 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | (defnet clear-projects-cb (self) 92 | (opt (clear-projects-low self)) ) 93 | 94 | (defnet clear-projects-low (self) 95 | (deflocal q l) 96 | 97 | (set q (queue)) 98 | (sqlite3-exec-data _db (netptr clear-projects-cback) q 99 | "SELECT name,path1,path2 FROM projects" ) 100 | (set l (length q)) 101 | (if (= l 0) 102 | then (iup-info60 self $"There are no obsolete projects.") 103 | (fail) ) 104 | ;(print (sprintl q nl) nl) 105 | (iup-confirm60 self (sprint l ' ' (if (= l 1) $"obsolete project will be deleted." $"obsolete projects will be deleted.") nl 106 | $"Are you sure?" )) 107 | (sqlite3-exec _db undef 108 | "DELETE FROM projects WHERE name IN('" 109 | (sprintl q "','") "')" ) 110 | (gui-update) ) 111 | 112 | (defnet clear-projects-cback (q name path1 path2) 113 | (if (or (not (pathexists path1)) (not (pathexists path2))) 114 | then (queue-put q (sqlite3-escape-strings name)) )) 115 | 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | ;;;; ;;;; 119 | ;;;; ;;;; 120 | ;;;; ;;;; 121 | ;;;; ;;;; 122 | ;;;; ;;;; 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | 126 | (defnet clear-data-cb (self) 127 | (opt (clear-data-low self)) ) 128 | 129 | (defnet clear-data-low (self) 130 | (deflocal a q l) 131 | 132 | (set a (assoc)) 133 | (set q (queue)) 134 | (set true) ; può sembrare strano ma serve 135 | (alt (iup-progress 136 | (thread-create (netptr clear-data-th1) (thread-self) a q) 137 | self "Please wait" true false false false true ) 138 | (seq (sound-iup-error60 self "Error.") 139 | (fail) )) 140 | (set l (length q)) 141 | (if (= l 0) 142 | then (iup-info60 self $"There are no obsolete data.") 143 | (fail) ) 144 | ;(clear-data-tmp q) 145 | (iup-confirm60 self (+ (if (= l 1) $"1 obsolete data will be deleted." 146 | (sprint l $" obsolete data will be deleted.") ) nl 147 | $"Are you sure?" )) 148 | (alt (iup-progress 149 | (thread-create (netptr clear-data-th2) (thread-self) q) 150 | self "Deleting..." true false false false true ) 151 | (seq (sound-iup-error60 self "Error.") 152 | (fail) ))) 153 | 154 | ;(defnet clear-data-tmp (q) 155 | ; (deflocal i) 156 | ; 157 | ; (for i in q do 158 | ; (opt (lmatch i "scd-") 159 | ; (print <(cfg-get i) 3> nl) ))) 160 | 161 | (defnet clear-data-th1 (th a q) 162 | (deflocal res) 163 | 164 | (alt (seq (sqlite3-exec-data _db (netptr clear-data-cback1) a 165 | "SELECT path,name FROM paths" ) 166 | (sqlite3-exec-data _db (netptr clear-data-cback2) (cons a q) 167 | "SELECT key FROM config" ) 168 | (set res "q") ) 169 | (set res "a") ) 170 | (send res to th) ) 171 | 172 | (defnet clear-data-cback1 (a path name) 173 | (deflocal av) 174 | 175 | (if (pathexists path) 176 | then (set av (av-avformat-open-input path)) 177 | (if (<> av undef) 178 | then (set true) 179 | (close av) ))) 180 | 181 | (defnet clear-data-cback2 (a key) 182 | (deflocal q l code1 code2) 183 | 184 | (set q (cdr a)) 185 | (set a (car a)) 186 | (if (in (length key) [ 44 84 ]) 187 | then (set code1 (sub 4 40 key)) 188 | (set code2 (sub 44 40 key)) ) 189 | (case (sub 0 4 key) of 190 | "scd-" (if (not (in code1 a)) 191 | then (queue-put q key) ) 192 | "sck-" (if (or (not (in code1 a)) (not (in code2 a))) 193 | then (queue-put q key) ) 194 | "map-" (if (or (not (in code1 a)) (not (in code2 a))) 195 | then (queue-put q key) ) 196 | "prm-" (if (or (not (in code1 a)) (not (in code2 a))) 197 | then (queue-put q key) ))) 198 | 199 | (defnet clear-data-th2 (th q) 200 | (deflocal res) 201 | 202 | (alt (seq (sqlite3-exec _db undef 203 | "DELETE FROM config WHERE key IN('" 204 | (sprintl q "','") "')" ) 205 | (set res "q") ) 206 | (set res "a") ) 207 | (send res to th) ) 208 | 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 211 | ;;;; ;;;; 212 | ;;;; ;;;; 213 | ;;;; ;;;; 214 | ;;;; ;;;; 215 | ;;;; ;;;; 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 218 | 219 | (defnet clear-scd1-cb (self) 220 | (opt (clear-scd-low self 1)) ) 221 | 222 | (defnet clear-scd2-cb (self) 223 | (opt (clear-scd-low self 2)) ) 224 | 225 | (defnet clear-scd-low (self which) 226 | (deflocal av key) 227 | 228 | (set av <_kv (+ "av" which)>) 229 | (<> av undef) 230 | (set key (key-scd av (fullpath->name <_kv (+ "path" which)>))) 231 | (truep (cfg-exists key)) 232 | (iup-confirm60 self 233 | (+ $"The \"scd\" data for movie" ' ' which ' ' $"will be deleted." nl $"Are you sure?") ) 234 | (cfg-clr key) 235 | (gui-update) ) 236 | 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 239 | ;;;; ;;;; 240 | ;;;; ;;;; 241 | ;;;; ;;;; 242 | ;;;; ;;;; 243 | ;;;; ;;;; 244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 245 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 246 | 247 | (defnet clear-sck-cb (self) 248 | (opt (clear-sck-low self)) ) 249 | 250 | (defnet clear-sck-low (self) 251 | (deflocal av1 av2 key) 252 | 253 | (set av1 <_kv "av1">) 254 | (<> av1 undef) 255 | (set av2 <_kv "av2">) 256 | (<> av2 undef) 257 | (set key (key-sck av1 av2 258 | (fullpath->name <_kv "path1">) 259 | (fullpath->name <_kv "path2">) )) 260 | (truep (cfg-exists key)) 261 | (iup-confirm60 self 262 | (+ $"The \"sift check\" data will be deleted." nl $"Are you sure?") ) 263 | (cfg-clr key) 264 | (gui-update) ) 265 | 266 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | ;;;; ;;;; 269 | ;;;; ;;;; 270 | ;;;; ;;;; 271 | ;;;; ;;;; 272 | ;;;; ;;;; 273 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | 276 | (defnet clear-failed-sck-cb (self) 277 | (opt (clear-failed-sck-low self)) ) 278 | 279 | (defnet clear-failed-sck-low (self) 280 | (deflocal av1 av2 key sck cache i) 281 | 282 | (set av1 <_kv "av1">) 283 | (<> av1 undef) 284 | (set av2 <_kv "av2">) 285 | (<> av2 undef) 286 | (set key (key-sck av1 av2 287 | (fullpath->name <_kv "path1">) 288 | (fullpath->name <_kv "path2">) )) 289 | (set sck (cfg-get key)) 290 | (<> sck undef) 291 | (set cache ) 292 | (set i (- (length cache) )) 293 | (if (= i 0) 294 | then (iup-info60 self $"There are no failed checks.") 295 | (fail) ) 296 | (iup-confirm60 self (+ (if (= i 1) $"1 failed check will be deleted." 297 | (sprint i $" failed checks will be deleted." )) nl $"Are you sure?" )) 298 | (for i in cache do 299 | (if (booleanp (cdr i)) 300 | then (if (not (cdr i)) 301 | then (assoc-clr cache (car i)) ))) 302 | (cfg-set key sck) 303 | (gui-report) ) 304 | 305 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 307 | ;;;; ;;;; 308 | ;;;; ;;;; 309 | ;;;; ;;;; 310 | ;;;; ;;;; 311 | ;;;; ;;;; 312 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 313 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 314 | 315 | (defnet clear-map-cb (self) 316 | (opt (clear-map-low self)) ) 317 | 318 | (defnet clear-map-low (self) 319 | (deflocal av1 av2 name1 name2 key prm) 320 | 321 | (set av1 <_kv "av1">) 322 | (<> av1 undef) 323 | (set av2 <_kv "av2">) 324 | (<> av2 undef) 325 | (set name1 (fullpath->name <_kv "path1">)) 326 | (set name2 (fullpath->name <_kv "path2">)) 327 | (set key (key-map av1 av2 name1 name2)) 328 | (truep (cfg-exists key)) 329 | (set prm (<> <_kv "prm"> undef)) 330 | (iup-confirm60 self 331 | (+ $"The \"mapping\" data will be deleted." nl 332 | (if prm (+ $"Warning: the \"sift check\" data will also be deleted." nl) "") 333 | $"Are you sure?") ) 334 | (sqlite3-begin _db) 335 | (alt (seq (cfg-clr key) 336 | (if prm 337 | then (cfg-clr (key-prm av1 av2 name1 name2)) 338 | (cfg-clr (key-sck av1 av2 name1 name2)) 339 | (assoc-clr _kv "prm") ) 340 | (sqlite3-end _db) ) 341 | (sqlite3-rollback _db) ) 342 | (gui-report) 343 | (gui-update) 344 | (if prm 345 | then (gui-update-image) )) 346 | 347 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 348 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 349 | ;;;; ;;;; 350 | ;;;; ;;;; 351 | ;;;; ;;;; 352 | ;;;; ;;;; 353 | ;;;; ;;;; 354 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 355 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 356 | 357 | (defnet clear-optimize-map-cb (self) 358 | (opt (clear-optimize-map-low self)) ) 359 | 360 | (defnet clear-optimize-map-low (self) 361 | (deflocal av1 av2 key k map p q n a i) 362 | 363 | (set av1 <_kv "av1">) 364 | (<> av1 undef) 365 | (set av2 <_kv "av2">) 366 | (<> av2 undef) 367 | (set key (key-map av1 av2 368 | (fullpath->name <_kv "path1">) 369 | (fullpath->name <_kv "path2">) )) 370 | (set k (cfg-get key)) 371 | (<> k undef) 372 | (set map (map-create )) 373 | (for i in do 374 | (set p ) 375 | (set q ) 376 | (set n ) 377 | (map-bind-low (car map) p q n) 378 | (map-bind-low (cdr map) q p n) ) 379 | (set a (array 0)) 380 | (for i in (car map) do 381 | (set q ) 382 | (if (integerp q) 383 | then (array-append a (list q (- -1))) )) 384 | (if (= (length ) (length a)) 385 | then (iup-info60 self $"The \"mapping\" data are already optimized.") 386 | (fail) ) 387 | (iup-confirm60 self 388 | (+ $"The \"mapping\" data will be optimized." nl 389 | "(" (length ) " -> " (length a) ")" nl 390 | $"Are you sure?" )) 391 | (cfg-set key (list a)) 392 | (gui-report) 393 | (gui-update) ) 394 | 395 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 396 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 397 | ;;;; ;;;; 398 | ;;;; ;;;; 399 | ;;;; ;;;; 400 | ;;;; ;;;; 401 | ;;;; ;;;; 402 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 403 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 404 | 405 | (defnet clear-data-tmp-cb (self) 406 | (opt (clear-data-tmp-low self)) ) 407 | 408 | (defnet clear-data-tmp-low (self) 409 | (deflocal q l) 410 | 411 | (set q (queue)) 412 | (alt (iup-progress 413 | (thread-create (netptr clear-data-tmp-th1) (thread-self) q) 414 | self "Please wait" true false false true ) 415 | (seq (sound-iup-error60 self "Error.") 416 | (fail) )) 417 | (set l (length q)) 418 | (if (= l 0) 419 | then (iup-info60 self "Non c'è niente da cancellare.") 420 | (fail) ) 421 | (iup-confirm60 self (+ (if (= l 1) $"1 obsolete data will be deleted." 422 | (sprint l $" obsolete data will be deleted.") ) nl 423 | $"Are you sure?" )) 424 | (alt (iup-progress 425 | (thread-create (netptr clear-data-th2) (thread-self) q) 426 | self "Deleting..." true false false true ) 427 | (seq (sound-iup-error60 self "Error.") 428 | (fail) ))) 429 | 430 | (defnet clear-data-tmp-th1 (th q) 431 | (deflocal res) 432 | 433 | (alt (seq (sqlite3-exec-data _db (netptr clear-data-tmp-cback) q 434 | "SELECT key FROM config" ) 435 | (set res "q") ) 436 | (set res "a") ) 437 | (send res to th) ) 438 | 439 | (defnet clear-data-tmp-cback (q key) 440 | (if (= (length key) 84) 441 | then (if (= (sub 4 40 key) (sub 44 40 key)) 442 | then (queue-put q key) ))) 443 | 444 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 445 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 446 | ;;;; ;;;; 447 | ;;;; ;;;; 448 | ;;;; ;;;; 449 | ;;;; ;;;; 450 | ;;;; ;;;; 451 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 452 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 453 | 454 | -------------------------------------------------------------------------------- /constants.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defun fc-width () 800) 12 | (defun fc-height () 600) 13 | (defun zoom-step () 1.1) 14 | (defun space () 10) 15 | (defun framerates () [ 25 (/ 24000 1001) 24 ]) 16 | 17 | (defun deint-filters () 18 | [ "none" 19 | "kerndeint" 20 | ]) 21 | 22 | (defun spp-filters () 23 | [ "none" 24 | "spp" 25 | "uspp" 26 | ]) 27 | 28 | (defun row-filters () 29 | [ "entire frame" 30 | "top field" 31 | "bottom field" 32 | ]) 33 | 34 | (defun default-parameters () 35 | [ [ "init-scd-threshold" . 15 ] 36 | [ "min-scd-threshold" . 3.5 ] 37 | [ "scd-threshold-ratio" . 0.95 ] 38 | [ "scd-min-blocks" . 4 ] 39 | [ "scd-min-avg-block-size" . 16 ] 40 | [ "final-closure" . false ] 41 | [ "checks-per-interval" . 4 ] 42 | [ "checks-per-interval-extra" . 8 ] 43 | [ "min-keypoints" . 60 ] 44 | [ "min-keypoints-min-ratio" . 0.05 ] 45 | [ "min-keypoints-min-ratio-lum" . 0.2 ] 46 | [ "sift-match-threshold-val" . 0.68 ] 47 | [ "sift-match-threshold-min-ratio" . 0.02 ] 48 | [ "sift-agreements-min" . 12000 ] 49 | [ "sift-proportionality-threshold" . 0.9 ] 50 | [ "sift-scale" . true ] 51 | [ "sift-scale-pixels" . (* 500 500) ] 52 | [ "filter-gamma1" . 1 ] 53 | [ "filter-gamma2" . 1 ] 54 | [ "filter-mirror1" . false ] 55 | [ "filter-mirror2" . false ] 56 | [ "filter-flip1" . false ] 57 | [ "filter-flip2" . false ] 58 | [ "filter-rotate1" . 0 ] 59 | [ "filter-rotate2" . 0 ] 60 | [ "filter-rows1" . 0 ] 61 | [ "filter-rows2" . 0 ] 62 | [ "filter-deint1" . 0 ] 63 | [ "filter-deint2" . 0 ] 64 | [ "filter-ar1-auto" . true ] 65 | [ "filter-ar1" . 1.78 ] 66 | [ "filter-ar2-auto" . true ] 67 | [ "filter-ar2" . 1.78 ] 68 | [ "sift-draw-lines" . true ] 69 | [ "supervision-skip-double" . 10 ] 70 | [ "scd-threads" . 4 ] 71 | [ "debug-enabled" . false ] 72 | [ "sound-enabled" . true ] 73 | [ "cuvid-enabled" . false ] 74 | [ "frame-buf-size" . 20 ] 75 | [ "scaling-mode" . 0 ] 76 | ]) 77 | 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | ;;;; ;;;; 81 | ;;;; ;;;; 82 | ;;;; ;;;; 83 | ;;;; ;;;; 84 | ;;;; ;;;; 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | -------------------------------------------------------------------------------- /ffmatch.trp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (include "common.tin") 12 | (include "lang.tin") 13 | (include "init.tin") 14 | (include "gui.tin") 15 | (include "move-sync.tin") 16 | (include "move-scd.tin") 17 | (include "move-spin.tin") 18 | (include "move-slide.tin") 19 | (include "force.tin") 20 | (include "cfg.tin") 21 | (include "utils.tin") 22 | (include "constants.tin") 23 | (include "scdscan.tin") 24 | (include "match.tin") 25 | (include "map.tin") 26 | (include "sift.tin") 27 | (include "audio.tin") 28 | (include "permute.tin") 29 | (include "threads.tin") 30 | (include "sound.tin") 31 | (include "clear.tin") 32 | (include "open.tin") 33 | (include "project.tin") 34 | (include "info.tin") 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | ;;;; ;;;; 39 | ;;;; ;;;; 40 | ;;;; ;;;; 41 | ;;;; ;;;; 42 | ;;;; ;;;; 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | 46 | (defstart ffmatch) 47 | 48 | (defnet ffmatch () 49 | (set-icon "emblem-videos.ico") 50 | (iup-set-lang) 51 | (init) 52 | (gui) 53 | (quit) ) 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;;;; ;;;; 58 | ;;;; ;;;; 59 | ;;;; ;;;; 60 | ;;;; ;;;; 61 | ;;;; ;;;; 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | 65 | -------------------------------------------------------------------------------- /force.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet force-cb (self) 12 | (opt (force-low self)) ) 13 | 14 | (defnet force-low (self) 15 | (deflocal key k a map n1 n2 d1 d2 p q n i u ut) 16 | 17 | (gui-not-locked) 18 | (set key (key-map <_kv "av1"> 19 | <_kv "av2"> 20 | (fullpath->name <_kv "path1">) 21 | (fullpath->name <_kv "path2">) )) 22 | (set k (cfg-get key)) 23 | (<> k undef) 24 | (set a ) 25 | (set map (map-create )) 26 | (set n1 (gui-spin-value 1)) 27 | (set n2 (gui-spin-value 2)) 28 | (for i in a do 29 | (set p ) 30 | (set q ) 31 | (set n ) 32 | (if (in n1 p .. (+ p n -1)) 33 | then (set d1 (for-pos)) ) 34 | (if (in n2 q .. (+ q n -1)) 35 | then (set d2 (for-pos)) ) 36 | (map-bind-low (car map) p q n) 37 | (map-bind-low (cdr map) q p n) ) 38 | (if (and (integerp d1) (= d1 d2)) 39 | then (set p ) 40 | (set q ) 41 | (if (= (- n1 p) (- n2 q)) 42 | then (iup-confirm60 self (sprint n1 $" is already linked to " n2 "." nl 43 | $"Do you want to remove the link?" )) 44 | (array-remove a d1) 45 | (force-low-update key k) 46 | (fail) )) 47 | (if (integerp d1) 48 | then (set p ) 49 | (set q ) 50 | (iup-confirm60 self (sprint n1 " (" $"movie" " 1)" $" is currently linked to " (+ q (- n1 p)) " (" $"movie" " 2)." nl 51 | $"Do you want to remove the link?" )) 52 | (array-remove a d1) 53 | (force-low-update key k) 54 | (fail) ) 55 | (if (integerp d2) 56 | then (set p ) 57 | (set q ) 58 | (iup-confirm60 self (sprint n2 " (" $"movie" " 2)" $" is currently linked to " (+ p (- n2 q)) " (" $"movie" " 1)." nl 59 | $"Do you want to remove the link?" )) 60 | (array-remove a d2) 61 | (force-low-update key k) 62 | (fail) ) 63 | ; n1 e n2 sono entrambi liberi 64 | (set p false) 65 | (for i in (map-undef-low-low (car map) (cdr map) true) do 66 | (set p (in n1 .. )) 67 | until p ) 68 | (truep p) ; non può mai fallire perché n1 è libero 69 | (if (in n2 .. ) 70 | then (iup-confirm60 self (sprint n1 $" will be linked to " n2 ". " $"Are you sure?")) 71 | (array-append a (list n1 n2 1)) 72 | 73 | ; qui si controlla se la creazione del link ha lasciato due 74 | ; zone di pari ampiezza (sia prima che dopo il link creato) 75 | ; e, in caso positivo, si chiede conferma all'utente se desidera 76 | ; collegare tutto l'intervallo... 77 | 78 | (map-bind-low (car map) n1 n2 1) 79 | (map-bind-low (cdr map) n2 n1 1) 80 | (set u (map-undef-low (car map) (cdr map))) 81 | (set ut (queue-get u)) 82 | (for i in (car map) do 83 | (if (= undef) 84 | then (if (and (= ) (= )) 85 | then (opt (or (= (+ 1) n1) (= (+ n1 1))) 86 | (set n (- -1)) 87 | (= n (- -1)) 88 | (iup-confirm60 self (+ $"Do you want to link these segments" " {" n "}?" nl 89 | "[" (int->str 6 '0') "-" (int->str 6 '0') "] <-> [" 90 | (int->str 6 '0') "-" (int->str 6 '0') "]" )) 91 | (array-append a (list n)) ) 92 | (set ut (queue-get u)) ))) 93 | 94 | (force-low-update key k) 95 | (fail) ) 96 | (set p false) 97 | (for u in (map-undef-low-low (cdr map) (car map) true) do 98 | (set p (in n2 .. )) 99 | until p ) 100 | (truep p) ; non può mai fallire perché n2 è libero 101 | (set p ) 102 | (set q (if (> n2 ) (+ 1) )) 103 | (set n (- -1)) 104 | (iup-confirm60 self (+ $"Do you want to move [" p "-" $"] (movie 2) to " q "?")) 105 | (if (> q p) 106 | then (dec q n) ) 107 | (sqlite3-begin _db) 108 | (alt (iup-progress 109 | (thread-create (netptr force-low-move-th) (thread-self) p q n) 110 | self "Moving..." true false false false true ) 111 | (seq (sqlite3-rollback _db) 112 | (sound-iup-error60 self "Error.") 113 | (fail) )) 114 | (sqlite3-end _db) 115 | (gui-spin-set-value 2 (+ q (- n2 p))) 116 | (gui-report-low false) 117 | (gui-print-selected-cb self) 118 | (gui-move-text1-on-current-value 1) 119 | (gui-update) ) 120 | 121 | (defnet force-low-update (key k) 122 | (cfg-set key k) 123 | (gui-report-low false) 124 | (gui-move-text1-on-current-value 1) 125 | (gui-update) ) 126 | 127 | (defnet force-low-move-th (th src dst n) 128 | (alt (seq (force-low-move-low src dst n) 129 | (send "q" to th) ) 130 | (send "a" to th) )) 131 | 132 | (defnet force-low-move-low (src dst n) 133 | (deflocal av1 av2 name1 name2 pix1 pix2) 134 | 135 | (set av1 <_kv "av1">) 136 | (<> av1 undef) 137 | (set av2 <_kv "av2">) 138 | (<> av2 undef) 139 | (set name1 (fullpath->name <_kv "path1">)) 140 | (set name2 (fullpath->name <_kv "path2">)) 141 | (set pix1 (pix-create (width av2) (height av2))) 142 | (pixp pix1) 143 | (set pix2 (pix-create (width av2) (height av2))) 144 | (if (not (pixp pix2)) 145 | then (close pix1) 146 | (fail) ) 147 | (alt (force-low-move-low-low src dst n av1 av2 name1 name2 pix1 pix2) 148 | (seq (close pix1 pix2) 149 | (fail) )) 150 | (close pix1 pix2) ) 151 | 152 | (defnet force-low-move-low-low (src dst n av1 av2 name1 name2 pix1 pix2) 153 | (deflocal key k id p a b c i j l) 154 | 155 | (set key (key-map av1 av2 name1 name2)) 156 | (set k (cfg-get key)) 157 | (set id (perm-identity )) 158 | (set p (perm-move id dst src n)) 159 | (set a ) 160 | (for i in 0 .. (- (length a) 1) do 161 | (set (list

> )) ) 162 | (cfg-set key k) 163 | 164 | (set key (key-sck av1 av2 name1 name2)) 165 | (set k (cfg-get key)) 166 | (set a (assoc)) 167 | (for i in (car k) do 168 | (set str

num (sub 6 6 (car i)))> 6 '0'))> (cdr i)) ) 169 | (set k (cons a (cdr k))) 170 | (cfg-set key k) 171 | 172 | (set key (key-prm av1 av2 name1 name2)) 173 | (set k (cfg-get key)) 174 | (if (= k undef) 175 | then (set k (cons (array 0) <(cfg-get (key-scd av2 name2)) 4>)) ) 176 | (set a (car k)) 177 | (set b (cdr k)) 178 | (array-append a (list src dst n)) 179 | (set c (array (length b))) 180 | (set p (perm-inverse p)) 181 | (set l 0) 182 | (for i in 0 .. (- (length c) 1) do 183 | (set j

) 184 | (if (= j undef) 185 | then (set j i) ) 186 | (if (and (<> j l) (> l 0)) 187 | then (av-read-frame av2 pix1 (perm-convert (- l 1))) 188 | (av-read-frame av2 pix2 (perm-convert j)) 189 | (set (pix-scd-histogram pix1 pix2)) 190 | else (set ) ) 191 | (set l (+ j 1)) ) 192 | (cfg-set key (cons a c)) 193 | 194 | (set p id) 195 | (for i in a do 196 | (set p (perm-move p )) ) 197 | 198 | (set <_kv "prm"> p) ) 199 | 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | ;;;; ;;;; 203 | ;;;; ;;;; 204 | ;;;; ;;;; 205 | ;;;; ;;;; 206 | ;;;; ;;;; 207 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 208 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 | 210 | (defnet force-undo-last-movement-cb (self) 211 | (opt (force-undo-last-movement-low self)) ) 212 | 213 | (defnet force-undo-last-movement-low (self) 214 | (deflocal av1 av2 name1 name2 key-prm k-prm key-map k-map a src dst n l i j) 215 | 216 | (gui-not-locked) 217 | (<> <_kv "prm"> undef) 218 | (set av1 <_kv "av1">) 219 | (<> av1 undef) 220 | (set av2 <_kv "av2">) 221 | (<> av2 undef) 222 | (set name1 (fullpath->name <_kv "path1">)) 223 | (set name2 (fullpath->name <_kv "path2">)) 224 | (set key-prm (key-prm av1 av2 name1 name2)) 225 | (set k-prm (cfg-get key-prm)) 226 | (<> k-prm undef) 227 | (set a (car k-prm)) 228 | (> (length a) 0) 229 | (set n ) 230 | (set src ) 231 | (set dst ) 232 | (set n ) 233 | (set key-map (key-map av1 av2 name1 name2)) 234 | (set k-map (cfg-get key-map)) 235 | (set l nil) 236 | (if (<> k-map undef) 237 | then (set j (+ dst n -1)) 238 | (for i in do 239 | (if (and (>= (+ -1) dst) (<= j)) 240 | then (list-push l (for-pos)) ))) 241 | (iup-confirm60 self (+ $"The last movement will be undone." nl 242 | (if (<> l nil) (+ $"Warning" ": " (length l) $" link(s) will also be deleted." nl) "") 243 | $"Are you sure?" )) 244 | (sqlite3-begin _db) 245 | (alt (iup-progress 246 | (thread-create (netptr force-undo-last-movement-th) (thread-self) dst src n key-prm key-map k-map l) 247 | self "Coming back..." true false false false true ) 248 | (seq (sqlite3-rollback _db) 249 | (sound-iup-error60 self "Error.") 250 | (fail) )) 251 | (sqlite3-end _db) 252 | (gui-spin-set-value 2 <(perm-move (perm-identity ) src dst n) (gui-spin-value 2)>) 253 | (gui-report-low false) 254 | (gui-print-selected-cb self) 255 | (gui-move-text1-on-current-value 1) 256 | (gui-update) ) 257 | 258 | (defnet force-undo-last-movement-th (th src dst n key-prm key-map k-map l) 259 | (alt (seq (force-undo-last-movement-th-low src dst n key-prm key-map k-map l) 260 | (send "q" to th) ) 261 | (send "a" to th) )) 262 | 263 | (defnet force-undo-last-movement-th-low (src dst n key-prm key-map k-map l) 264 | (deflocal k-prm a i) 265 | 266 | (if (<> l nil) 267 | then (for i in l do 268 | (array-remove i) ) 269 | (cfg-set key-map k-map) ) 270 | (force-low-move-low src dst n) 271 | (set k-prm (cfg-get key-prm)) 272 | (set a (car k-prm)) 273 | (array-remove a (- (length a) 1)) 274 | (array-remove a (- (length a) 1)) 275 | (if (= (length a) 0) 276 | then ;(set i <_kv "prm">) 277 | ;(set j (perm-max i)) 278 | ;(print "test identity (" j "): " (= i (perm-identity j)) nl) 279 | ;(set i (cdr (cfg-get key-prm))) 280 | ;(set j <(cfg-get (key-scd av2 name2)) 4>) 281 | ;(print "test scd: " (= i j) nl) 282 | (cfg-clr key-prm) 283 | (assoc-clr _kv "prm") 284 | else (cfg-set key-prm k-prm) )) 285 | 286 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 287 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 288 | ;;;; ;;;; 289 | ;;;; ;;;; 290 | ;;;; ;;;; 291 | ;;;; ;;;; 292 | ;;;; ;;;; 293 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | 296 | (defnet force-final-closure-cb (self) 297 | (opt (force-final-closure-low self)) ) 298 | 299 | (defnet force-final-closure-low (self) 300 | (deflocal key k a map p q n cf i) 301 | 302 | (gui-not-locked) 303 | (set key (key-map <_kv "av1"> 304 | <_kv "av2"> 305 | (fullpath->name <_kv "path1">) 306 | (fullpath->name <_kv "path2">) )) 307 | (set k (cfg-get key)) 308 | (<> k undef) 309 | (set a ) 310 | (set map (map-create )) 311 | (for i in a do 312 | (set p ) 313 | (set q ) 314 | (set n ) 315 | (map-bind-low (car map) p q n) 316 | (map-bind-low (cdr map) q p n) ) 317 | (set cf (queue)) 318 | (set n 0) 319 | (for i in (map-undef-low (car map) (cdr map)) do 320 | (set p (- -1)) 321 | (if (= p (- -1)) 322 | then (queue-put cf i) 323 | (inc n p) )) 324 | (if (= (length cf) 0) 325 | then (iup-info60 self $"There are no segments to close.") 326 | (fail) ) 327 | (iup-confirm60 self (+ $"Segments to close: " (length cf) " (" n " frames)." nl $"Are you sure?")) 328 | (for i in cf do 329 | (array-append a (list (- -1))) ) 330 | (force-low-update key k) ) 331 | 332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 333 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 334 | ;;;; ;;;; 335 | ;;;; ;;;; 336 | ;;;; ;;;; 337 | ;;;; ;;;; 338 | ;;;; ;;;; 339 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 340 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 341 | 342 | -------------------------------------------------------------------------------- /icons/emblem-videos.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fsinapsi/ffmatch/cb9b3c06be2ee679235cc8b65ae960516992a5c1/icons/emblem-videos.ico -------------------------------------------------------------------------------- /icons/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fsinapsi/ffmatch/cb9b3c06be2ee679235cc8b65ae960516992a5c1/icons/logo.png -------------------------------------------------------------------------------- /info.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet info-cb (self) 12 | (deflocal q butbox dlg i) 13 | 14 | (set q (queue)) 15 | 16 | (set butbox (iup-box-ok undef q)) 17 | 18 | (set i (iup-vbox 19 | (info-setup-tabs q) 20 | butbox )) 21 | (iup-set-str-attribute i "MARGIN" "4x4") 22 | (iup-set-int i "GAP" 0) 23 | 24 | (set dlg (iup-dialog i)) 25 | (iup-set-dlg-parent self dlg) 26 | (iup-set-str-attribute dlg "TITLE" $"About FFmatch") 27 | (iup-set-bool dlg "DIALOGFRAME" true) 28 | (iup-set-attribute-handle dlg "DEFAULTENTER" (iup-box-ok-btn butbox)) 29 | (iup-set-attribute-handle dlg "DEFAULTESC" (iup-box-ok-btn butbox)) 30 | 31 | (iup-popup dlg (cmacro IUP_CENTERPARENT) (cmacro IUP_CENTERPARENT)) 32 | 33 | (close dlg) 34 | (iup-close-queue q) ) 35 | 36 | (defun info-setup-tabs (q) net info-setup-tabs) 37 | (defnet info-setup-tabs (q @wid) 38 | (set @wid (iup-tabs (info-setup-page1 q) (info-setup-page2) (info-setup-page3) (info-setup-page4))) 39 | (iup-set-str-attribute @wid "TABTITLE0" $"Version") 40 | (iup-set-str-attribute @wid "TABTITLE1" $"Authors") 41 | (iup-set-str-attribute @wid "TABTITLE2" "Lavc") 42 | (iup-set-str-attribute @wid "TABTITLE3" $"License") 43 | (if (clinux) 44 | then (iup-set-bgcolor @wid (white)) ) 45 | (iup-set-bool @wid "EXPAND" true) ) 46 | 47 | (defun info-setup-page1 (q) net info-setup-page1) 48 | (defnet info-setup-page1 (q @wid) 49 | (deflocal i img remote-version vbox) 50 | 51 | (set i (iup-label)) 52 | (iup-set-str-attribute i "EXPAND" "VERTICAL") 53 | (set img (iup-image-rgba (pix-load-static "logo.png"))) 54 | (iup-set-attribute-handle i "IMAGE" img) 55 | (queue-put q img) 56 | 57 | (set remote-version (remote-version-cached)) 58 | 59 | (set vbox (iup-vbox 60 | (iup-fill) 61 | (iup-label 62 | "FFmatch version: " (date->version (compile-time)) " (" (csysbits) "-bit)" ) 63 | (if (< (compile-time) remote-version) 64 | (iup-link (+ (url-home-page) "/code/ffmatch/index.html") $"There is an update" ": " (date->version remote-version)) 65 | (iup-label $"There are no updates") ) 66 | (iup-label 67 | "CPUs: " (openjp2-get-num-cpus) nl 68 | $"Current number of threads" ": " (thread-cur) nl 69 | $"Max number of threads" ": " (thread-max) nl 70 | $"Selected language" ": " <(languages) (lang)> nl 71 | ;$"Sound" ": " (if <_kv "enabled-sound"> $"enabled" $"disabled") nl 72 | "CC version (rts): " (sub 0 30 (cc-version)) nl 73 | "GC version: " (gc-version) nl 74 | "GMP version: " (gmp-version) nl 75 | "IUP version: " (iup-version) nl 76 | "IUP system: " (iup-get-global "SYSTEM") nl 77 | (if (clinux) (+ "GTK version: " (iup-get-global "GTKVERSION") nl) "") 78 | "IUP DEFAULTFONT: " (iup-get-global "DEFAULTFONT") nl 79 | "libavcodec version: " (av-codec-version) "/" (av-avcodec-version) nl ) 80 | (iup-fill) )) 81 | (iup-set-int vbox "GAP" 0) 82 | (set @wid (iup-hbox (iup-fill) i vbox (iup-fill))) 83 | (iup-set-str-attribute @wid "ALIGNMENT" "ACENTER") 84 | (iup-set-int @wid "GAP" 40) ) 85 | 86 | (defun info-setup-page2 () net info-setup-page2) 87 | (defnet info-setup-page2 (@wid) 88 | (set @wid (iup-vbox 89 | (iup-label "FFmatch " $"was coded in TreeP by" " Frank Sinapsi") 90 | (iup-link (url-home-page)) 91 | (iup-label "\n" $"Please report bugs to") 92 | (iup-link "mailto:fsinapsi@yahoo.it" "fsinapsi@yahoo.it") 93 | (iup-label "\n" $"Source code of" " " "TreeP") 94 | (iup-link "https://github.com/fsinapsi/TreeP") 95 | (iup-label "\n" $"Source code of" " " "FFmatch") 96 | (iup-link "https://github.com/fsinapsi/ffmatch") 97 | (iup-label "\n" $"Thanks to:" 98 | "\n" "HoHoHo, Devilman1, ErTenebra" ))) 99 | (iup-set-str-attribute @wid "MARGIN" "20x20") ) 100 | 101 | (defun info-setup-page3 () net info-setup-page3) 102 | (defnet info-setup-page3 (@wid) 103 | (deflocal s c a) 104 | 105 | (set a (array 0)) 106 | (for c in (av-avcodec-list) do 107 | (if (= (cmacro AVMEDIA_TYPE_VIDEO)) 108 | then (array-append a c) )) 109 | (sort a (funptr less1)) 110 | (set s (+ "Configuration:" nl 111 | nl 112 | (av-avcodec-configuration) nl 113 | nl 114 | "Video codecs (" (length a) "):" nl )) 115 | (for c in a do 116 | (inc s nl " (" ")") ) 117 | (set a (array 0)) 118 | (for c in (av-decoder-name-list) do 119 | (array-append a c) ) 120 | (sort a) 121 | (inc s nl 122 | nl 123 | "Decoders (" (length a) "):" nl ) 124 | (for c in a do 125 | (inc s nl c) ) 126 | (set @wid (iup-text-generic s true)) ) 127 | 128 | (defun info-setup-page4 () 129 | (iup-text-generic (+ 130 | (if (= (lang) 1) 131 | "FFmatch è un software libero: puoi ridistribuirlo e/o\n" \ 132 | "modificarlo secondo i termini della GNU General Public License\n" \ 133 | "come pubblicata da Free Software Foundation, versione 3 della\n" \ 134 | "licenza o (a tua scelta) qualsiasi versione successiva.\n" \ 135 | "\n" \ 136 | "FFmatch è distribuito nella speranza che sia utile, ma\n" \ 137 | "SENZA ALCUNA GARANZIA; senza nemmeno la garanzia implicita di\n" \ 138 | "COMMERCIABILITÀ o IDONEITÀ PER UNO SCOPO PARTICOLARE.\n" \ 139 | "Vedere la GNU General Public License per maggiori dettagli." 140 | 141 | "FFmatch is free software: you can redistribute it and/or modify it\n" \ 142 | "under the terms of the GNU General Public License as published by the\n" \ 143 | "Free Software Foundation, either version 3 of the License, or\n" \ 144 | "(at your option) any later version.\n" \ 145 | "\n" \ 146 | "FFmatch is distributed in the hope that it will be useful, but\n" \ 147 | "WITHOUT ANY WARRANTY; without even the implied warranty of\n" \ 148 | "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n" \ 149 | "See the GNU General Public License for more details." ) 150 | nl 151 | "----------------------------------------------------------" nl 152 | nl 153 | (license-gpl3) ) 154 | false )) 155 | 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | ;;;; ;;;; 159 | ;;;; ;;;; 160 | ;;;; ;;;; 161 | ;;;; ;;;; 162 | ;;;; ;;;; 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | (defnet info-keyboard-shortcuts-cb (self) 167 | (deflocal q butbox text dlg i) 168 | 169 | (set q (queue)) 170 | 171 | (set butbox (iup-box-ok undef q)) 172 | 173 | (set text (iup-text-generic (info-keyboard-shortcuts) false)) 174 | 175 | (set i (iup-vbox text butbox)) 176 | (iup-set-str-attribute i "MARGIN" "4x4") 177 | (iup-set-int i "GAP" 0) 178 | 179 | (set dlg (iup-dialog i)) 180 | (iup-set-dlg-parent self dlg) 181 | (iup-set-str-attribute dlg "TITLE" $"Keyboard shortcuts") 182 | (iup-set-str-attribute dlg "RASTERSIZE" "660x400") 183 | (iup-set-bool dlg "DIALOGFRAME" true) 184 | (iup-set-attribute-handle dlg "DEFAULTENTER" (iup-box-ok-btn butbox)) 185 | (iup-set-attribute-handle dlg "DEFAULTESC" (iup-box-ok-btn butbox)) 186 | 187 | (iup-map dlg) 188 | (iup-set-int text "CARETPOS" 0) 189 | 190 | ;(iup-set-focus (iup-box-ok-btn butbox)) 191 | 192 | (iup-popup dlg (cmacro IUP_CENTERPARENT) (cmacro IUP_CENTERPARENT)) 193 | 194 | (close dlg) 195 | (iup-close-queue q) ) 196 | 197 | (defun info-keyboard-shortcuts () 198 | "F5: start\n" \ 199 | "Esc: abort\n" \ 200 | "Ctrl+1: selects the segment to which frame 1 belongs\n" \ 201 | "Ctrl+2: selects the segment to which frame 2 belongs\n" \ 202 | "Shift+'left arrow': same as 'simple blue left arrow button'\n" \ 203 | "Shift+'right arrow': same as 'simple blue right arrow button'\n" \ 204 | "Ctrl+'left arrow': same as 'double blue left arrow button'\n" \ 205 | "Ctrl+'right arrow': same as 'double blue right arrow button'\n" \ 206 | "Ctrl+Shift+'left arrow': same as 'first of segment blue left arrow button'\n" \ 207 | "Ctrl+Shift+'right arrow': same as 'last of segment blue right arrow button'\n" \ 208 | "Ctrl+Enter: same as 'link button'\n" \ 209 | "'down arrow': ...\n" \ 210 | "'up arrow': ...\n" \ 211 | "Shift+'down arrow': ...\n" \ 212 | "Shift+'up arrow': ...\n" \ 213 | "Tab: ...\n" \ 214 | "\n" \ 215 | "\n" 216 | ) 217 | 218 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | ;;;; ;;;; 221 | ;;;; ;;;; 222 | ;;;; ;;;; 223 | ;;;; ;;;; 224 | ;;;; ;;;; 225 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 226 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 227 | 228 | -------------------------------------------------------------------------------- /init.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defglobal _kv _abort) 12 | 13 | (defnet init () 14 | ;(if (cmingw) 15 | ;then (iup-set-str-global "DEFAULTFONTSIZE" 10) ) 16 | (set _kv (assoc)) 17 | (set <_kv "da-chiudere"> (queue)) 18 | (set <_kv "zoom-level"> 0) 19 | (init-parse-args) 20 | (init-db) 21 | (init-default) 22 | (init-threads) 23 | (set <_kv "sound-enabled"> (cfg-get-or-default "sound-enabled" <_kv "default">)) 24 | (set _abort (array default false 1)) ) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;;;; ;;;; 29 | ;;;; ;;;; 30 | ;;;; ;;;; 31 | ;;;; ;;;; 32 | ;;;; ;;;; 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (defnet init-parse-args () 37 | (deflocal i p) 38 | 39 | (for i in 1 .. (- (argc) 1) do 40 | (set p (argv i)) 41 | (alt (seq (lmatch remove p "--cfg=") 42 | (set <_kv "cfg-path"> p) ) 43 | (seq (iup-error60 undef (+ (utf8-validate p) $": invalid option")) 44 | (exit -1) )))) 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;;;; ;;;; 49 | ;;;; ;;;; 50 | ;;;; ;;;; 51 | ;;;; ;;;; 52 | ;;;; ;;;; 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | 56 | (defnet init-db () 57 | (deflocal path crea) 58 | 59 | (set path <_kv "cfg-path">) 60 | (if (= path undef) 61 | then (if (cmingw) 62 | then (set path (callpathp "ffmatch.cfg")) 63 | else (set path (datapath)) 64 | (if (= path undef) 65 | then (iup-error60 undef "please define the environment variable `HOME'") 66 | (exit -2) ) 67 | (alt (pathexists path) 68 | (mkdir path) 69 | (seq (iup-error60 undef (+ "creation of directory `" (utf8-validate path) "' failed")) 70 | (exit -3) )) 71 | (inc path "ffmatch.cfg") )) 72 | (set crea (not (pathexists path))) 73 | (set _db (sqlite3-open path)) 74 | (if (= _db undef) 75 | then (iup-error60 undef (+ "cannot open `" (utf8-validate path) "'")) 76 | (exit -4) ) 77 | (set <_kv "debug-path"> (path-change-extension path "log")) 78 | (da-chiudere _db) 79 | (alt (not crea) 80 | (seq (cfg-create-table) 81 | (cfg-set "date-run-first" (now)) 82 | (iup-info60 undef (+ "the settings file was saved as `" (utf8-validate path) "'")) ) 83 | (seq (close _db) 84 | (remove path) 85 | (iup-error60 undef "creation of settings file failed") 86 | (exit -5) )) 87 | (cfg-set "cdate" (cdate)) 88 | (cfg-set "date-run-last" (now)) 89 | (cfg-inc "runs" 1) 90 | (db-begin) 91 | (opt (sqlite3-exec _db undef 92 | "CREATE TABLE paths(" \ 93 | "path char unique not null," \ 94 | "name char not null)" ) 95 | (sqlite3-exec _db undef 96 | "CREATE INDEX paths_name ON paths(name)" )) 97 | (opt (sqlite3-exec _db undef 98 | "CREATE TABLE projects(" \ 99 | "name char unique not null," \ 100 | "path1 char not null," \ 101 | "path2 char not null)" ) 102 | (sqlite3-exec _db undef 103 | "CREATE INDEX projects_path1 ON projects(path1)" ) 104 | (sqlite3-exec _db undef 105 | "CREATE INDEX projects_path2 ON projects(path2)" )) 106 | (db-end) 107 | (set-lang (cfg-get-lang)) 108 | (set <_kv "debug-enabled"> (= (cfg-get "debug-enabled") true)) ) 109 | 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | ;;;; ;;;; 113 | ;;;; ;;;; 114 | ;;;; ;;;; 115 | ;;;; ;;;; 116 | ;;;; ;;;; 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | 120 | (defnet init-default () 121 | (set <_kv "default"> (assoc-default (default-parameters))) ) 122 | 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | ;;;; ;;;; 126 | ;;;; ;;;; 127 | ;;;; ;;;; 128 | ;;;; ;;;; 129 | ;;;; ;;;; 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | 133 | (defnet init-threads () 134 | (deflocal i) 135 | 136 | (alt (for i in (list (cons "th-clock" (netptr th-clock)) 137 | (cons "th-read-frame1" (netptr th-read-frame)) 138 | (cons "th-read-frame2" (netptr th-read-frame)) 139 | (cons "th-sound" (netptr th-sound)) ) do 140 | (set <_kv (car i)> (thread-create (cdr i) (thread-self))) 141 | (threadp <_kv (car i)>) ) 142 | (seq (iup-error60 undef "creation of thread failed") 143 | (exit -6) ))) 144 | 145 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | ;;;; ;;;; 148 | ;;;; ;;;; 149 | ;;;; ;;;; 150 | ;;;; ;;;; 151 | ;;;; ;;;; 152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | 155 | -------------------------------------------------------------------------------- /lang.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defun languages () 12 | [ "English" 13 | "Italiano" 14 | ]) 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;;;; ;;;; 19 | ;;;; ;;;; 20 | ;;;; ;;;; 21 | ;;;; ;;;; 22 | ;;;; ;;;; 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | (deflang 27 | 28 | "Help" 29 | 1 30 | "Aiuto" 31 | 32 | "About FFmatch" 33 | 1 34 | "Info su FFmatch" 35 | 36 | ": invalid option" 37 | 1 38 | ": opzione non valida" 39 | 40 | "Close" 41 | 1 42 | "Chiudi" 43 | 44 | "Cancel" 45 | 1 46 | "Annulla" 47 | 48 | "Preferences" 49 | 1 50 | "Preferenze" 51 | 52 | "Language" 53 | 1 54 | "Lingua" 55 | 56 | "Changing the language requires a restart to take effect." 57 | 1 58 | "Per usufruire della modifica della lingua occorre far ripartire il programma." 59 | 60 | "File `" 61 | 1 62 | "Il file `" 63 | 64 | "' exists." 65 | 1 66 | "' esiste già." 67 | 68 | "Do you want to overwrite it?" 69 | 1 70 | "Vuoi sovrascriverlo?" 71 | 72 | " is already linked to " 73 | 1 74 | " è già collegato a " 75 | 76 | " is currently linked to " 77 | 1 78 | " è attualmente collegato a " 79 | 80 | "Do you want to remove the link?" 81 | 1 82 | "Vuoi rimuovere il collegamento?" 83 | 84 | " will be linked to " 85 | 1 86 | " verrà collegato a " 87 | 88 | "Do you want to move [" 89 | 1 90 | "Vuoi spostare [" 91 | 92 | "] (movie 2) to " 93 | 1 94 | "] (filmato 2) verso " 95 | 96 | "Save frame " 97 | 1 98 | "Salva il frame " 99 | 100 | " as..." 101 | 1 102 | " come..." 103 | 104 | "checks: " 105 | 1 106 | "controlli: " 107 | 108 | " (passed: " 109 | 1 110 | " (passati: " 111 | 112 | "horizontal ratio: " 113 | 1 114 | "rapporto orizzontale: " 115 | 116 | "vertical ratio: " 117 | 1 118 | "rapporto verticale: " 119 | 120 | "\n1st movie frame(s) not found in the 2nd one:\n" 121 | 1 122 | "\nframe(s) del primo filmato che non sono presenti nel secondo:\n" 123 | 124 | "\n2nd movie frame(s) not found in the 1st one:\n" 125 | 1 126 | "\nframe(s) del secondo filmato che non sono presenti nel primo:\n" 127 | 128 | "Select movie 1" 129 | 1 130 | "Seleziona il filmato 1" 131 | 132 | "Select movie 2" 133 | 1 134 | "Seleziona il filmato 2" 135 | 136 | "Select path 1" 137 | 1 138 | "Seleziona il path 1" 139 | 140 | "Select path 2" 141 | 1 142 | "Seleziona il path 2" 143 | 144 | "Swap order" 145 | 1 146 | "Scambia l'ordine" 147 | 148 | "Save top text as..." 149 | 1 150 | "Salva il testo di sopra come..." 151 | 152 | "Save bottom text as..." 153 | 1 154 | "Salva il testo di sotto come..." 155 | 156 | "Save frame 1 as..." 157 | 1 158 | "Salva il frame 1 come..." 159 | 160 | "Save frame 2 as..." 161 | 1 162 | "Salva il frame 2 come..." 163 | 164 | "Exit" 165 | 1 166 | "Esci" 167 | 168 | "Print the valid paths" 169 | 1 170 | "Stampa i path validi" 171 | 172 | "Obsolete paths" 173 | 1 174 | "Path obsoleti" 175 | 176 | "Valid paths" 177 | 1 178 | "Path validi" 179 | 180 | "Print obsolete paths" 181 | 1 182 | "Stampa i path obsoleti" 183 | 184 | "Print selected movie names" 185 | 1 186 | "Stampa i nomi dei filmati selezionati" 187 | 188 | "Print timestamps movie 1" 189 | 1 190 | "Stampa timestamps filmato 1" 191 | 192 | "Print timestamps movie 2" 193 | 1 194 | "Stampa timestamps filmato 2" 195 | 196 | "Report failed checks" 197 | 1 198 | "Riporta i controlli falliti" 199 | 200 | "Restore default parameters" 201 | 1 202 | "Resetta parametri default" 203 | 204 | "Sequences" 205 | 1 206 | "Sequenze" 207 | 208 | "Final closure" 209 | 1 210 | "Chiusura finale" 211 | 212 | "There are no segments to close." 213 | 1 214 | "Non ci sono segmenti da chiudere." 215 | 216 | "Segments to close: " 217 | 1 218 | "Segmenti da chiudere: " 219 | 220 | "enabled" 221 | 1 222 | "abilitato" 223 | 224 | "Checks" 225 | 1 226 | "Controlli" 227 | 228 | "Scaling" 229 | 1 230 | "Scalatura" 231 | 232 | "Filters" 233 | 1 234 | "Filtri" 235 | 236 | "Line drawing" 237 | 1 238 | "Disegno linee" 239 | 240 | "There are no obsolete paths." 241 | 1 242 | "Non ci sono path obsoleti." 243 | 244 | "There are no valid paths." 245 | 1 246 | "Non ci sono path validi." 247 | 248 | "There are no obsolete data." 249 | 1 250 | "Non ci sono dati obsoleti." 251 | 252 | "Select movie " 253 | 1 254 | "Seleziona il filmato " 255 | 256 | ": movie not supported" 257 | 1 258 | ": filmato non supportato" 259 | 260 | "Creation of file `" 261 | 1 262 | "La creazione del file `" 263 | 264 | "' failed." 265 | 1 266 | "' è fallita." 267 | 268 | "select movie 1" 269 | 1 270 | "seleziona il filmato 1" 271 | 272 | "select movie 2" 273 | 1 274 | "seleziona il filmato 2" 275 | 276 | "start" 277 | 1 278 | "avvia il riconoscimento" 279 | 280 | "abort" 281 | 1 282 | "interrompi" 283 | 284 | "audio tracks" 285 | 1 286 | "tracce audio" 287 | 288 | "preferences" 289 | 1 290 | "preferenze" 291 | 292 | "Clear" 293 | 1 294 | "Pulizia" 295 | 296 | "Clear \"scd\" data 1" 297 | 1 298 | "Cancella i dati \"scd\" del filmato 1" 299 | 300 | "Clear \"scd\" data 2" 301 | 1 302 | "Cancella i dati \"scd\" del filmato 2" 303 | 304 | "Clear \"sift check\" data" 305 | 1 306 | "Cancella i dati \"sift check\"" 307 | 308 | "Clear failed checks" 309 | 1 310 | "Cancella i controlli falliti" 311 | 312 | "Clear \"mapping\" data" 313 | 1 314 | "Cancella i dati di \"mapping\"" 315 | 316 | "Optimize \"mapping\" data" 317 | 1 318 | "Ottimizza i dati di \"mapping\"" 319 | 320 | "Clear obsolete paths" 321 | 1 322 | "Cancella i path obsoleti" 323 | 324 | "Clear obsolete data" 325 | 1 326 | "Cancella i dati obsoleti" 327 | 328 | "Clear top text" 329 | 1 330 | "Pulisci il testo di sopra" 331 | 332 | "Clear bottom text" 333 | 1 334 | "Pulisci il testo di sotto" 335 | 336 | "There are no failed checks." 337 | 1 338 | "Non ci sono controlli falliti." 339 | 340 | "The \"scd\" data for movie" 341 | 1 342 | "I dati \"scd\" del filmato" 343 | 344 | "will be deleted." 345 | 1 346 | "verranno cancellati." 347 | 348 | "Delete project" 349 | 1 350 | "Cancella progetto" 351 | 352 | "' will be deleted." 353 | 1 354 | "' verrà cancellato." 355 | 356 | "Project successfully deleted." 357 | 1 358 | "Il progetto è stato cancellato con successo." 359 | 360 | "The \"sift check\" data will be deleted." 361 | 1 362 | "I dati \"sift check\" verranno cancellati." 363 | 364 | "The \"mapping\" data will be deleted." 365 | 1 366 | "I dati di \"mapping\" verranno cancellati." 367 | 368 | "Warning: the \"sift check\" data will also be deleted." 369 | 1 370 | "Attenzione: anche i dati \"sift check\" verranno cancellati." 371 | 372 | "Default parameters will be restored." 373 | 1 374 | "Verranno ripristinati i parametri di default." 375 | 376 | "obsolete path will be deleted." 377 | 1 378 | "path obsoleto verrà cancellato." 379 | 380 | "obsolete paths will be deleted." 381 | 1 382 | "path obsoleti verranno cancellati." 383 | 384 | "1 obsolete data will be deleted." 385 | 1 386 | "1 dato obsoleto verrà cancellato." 387 | 388 | " obsolete data will be deleted." 389 | 1 390 | " dati obsoleti verranno cancellati." 391 | 392 | "movie" 393 | 1 394 | "filmato" 395 | 396 | "resolution" 397 | 1 398 | "risoluzione" 399 | 400 | "display resolution" 401 | 1 402 | "risoluzione di visualizzazione" 403 | 404 | "duration" 405 | 1 406 | "durata" 407 | 408 | "Aborted" 409 | 1 410 | "Analisi interrotta" 411 | 412 | "1 failed check will be deleted." 413 | 1 414 | "1 controllo fallito verrà cancellato." 415 | 416 | " failed checks will be deleted." 417 | 1 418 | " controlli falliti verranno cancellati." 419 | 420 | "Audio tracks" 421 | 1 422 | "Tracce audio" 423 | 424 | "select audio" 425 | 1 426 | "seleziona audio" 427 | 428 | "save track as..." 429 | 1 430 | "salva la traccia come..." 431 | 432 | "Select audio" 433 | 1 434 | "Seleziona audio" 435 | 436 | "It seems like the audio track contains extraneous data. Please fix it." 437 | 1 438 | "Sembra che la traccia audio contenga dati estranei. È consigliabile ripararla." 439 | 440 | "Please, select a valid frame rate" 441 | 1 442 | "Seleziona un frame rate valido" 443 | 444 | "Please, select both audio tracks" 445 | 1 446 | "Seleziona entrambe le tracce audio" 447 | 448 | "Audio tracks are not compatible" 449 | 1 450 | "Le tracce audio non sono compatibili" 451 | 452 | "Save audio track" 453 | 1 454 | "Salva traccia audio" 455 | 456 | "for video" 457 | 1 458 | "per il video" 459 | 460 | "as..." 461 | 1 462 | "come..." 463 | 464 | "It seems like stream lengths are inconsistent:" 465 | 1 466 | "Sembra che le lunghezze degli stream siano inconsistenti:" 467 | 468 | "duration of video" 469 | 1 470 | "durata del video" 471 | 472 | "duration of audio" 473 | 1 474 | "durata dell'audio" 475 | 476 | "Do you want to continue?" 477 | 1 478 | "Desideri continuare?" 479 | 480 | "Audio track successfully saved as `" 481 | 1 482 | "La traccia audio è stata salvata con successo come `" 483 | 484 | "I/O error." 485 | 1 486 | "errore di I/O." 487 | 488 | "elapsed time" 489 | 1 490 | "tempo trascorso" 491 | 492 | "to-mux" 493 | 1 494 | "da-muxare" 495 | 496 | "Version" 497 | 1 498 | "Versione" 499 | 500 | "Authors" 501 | 1 502 | "Autori" 503 | 504 | "License" 505 | 1 506 | "Licenza" 507 | 508 | "There is an update" 509 | 1 510 | "C'è un aggiornamento" 511 | 512 | "There are no updates" 513 | 1 514 | "Non ci sono aggiornamenti" 515 | 516 | "Selected language" 517 | 1 518 | "Lingua selezionata" 519 | 520 | "Selected SIFT impl." 521 | 1 522 | "Impl. SIFT selezionata" 523 | 524 | "was coded in TreeP by" 525 | 1 526 | "è stato scritto in TreeP da" 527 | 528 | "Please report bugs to" 529 | 1 530 | "Si prega di segnalare errori a" 531 | 532 | "Source code of" 533 | 1 534 | "Codice sorgente di" 535 | 536 | "approximate number of frames" 537 | 1 538 | "numero approssimato di fotogrammi" 539 | 540 | "Draw keypoints" 541 | 1 542 | "Disegna i keypoints" 543 | 544 | "Open project" 545 | 1 546 | "Apri progetto" 547 | 548 | "Save/rename project" 549 | 1 550 | "Salva/rinomina progetto" 551 | 552 | "open project" 553 | 1 554 | "apri progetto" 555 | 556 | "save/rename project" 557 | 1 558 | "salva/rinomina progetto" 559 | 560 | "Project name" 561 | 1 562 | "Nome del progetto" 563 | 564 | "Rename project" 565 | 1 566 | "Rinomina progetto" 567 | 568 | "Save project" 569 | 1 570 | "Salva progetto" 571 | 572 | "Project `" 573 | 1 574 | "Il progetto `" 575 | 576 | "' exists. Do you want to overwrite it?" 577 | 1 578 | "' esiste. Lo vuoi sovrascrivere?" 579 | 580 | "Project successfully saved." 581 | 1 582 | "Il progetto è stato salvato con successo." 583 | 584 | "There are no valid projects." 585 | 1 586 | "Non ci sono progetti validi." 587 | 588 | "Print obsolete projects" 589 | 1 590 | "Stampa i progetti obsoleti" 591 | 592 | "Obsolete projects" 593 | 1 594 | "Progetti obsoleti" 595 | 596 | "There are no obsolete projects." 597 | 1 598 | "Non ci sono progetti obsoleti." 599 | 600 | "Clear obsolete projects" 601 | 1 602 | "Cancella i progetti obsoleti" 603 | 604 | "obsolete project will be deleted." 605 | 1 606 | "progetto obsoleto verrà cancellato." 607 | 608 | "obsolete projects will be deleted." 609 | 1 610 | "progetti obsoleti verranno cancellati." 611 | 612 | "frame # " 613 | 1 614 | "il frame # " 615 | 616 | " is not recoverable by a seek" 617 | 1 618 | " non è recuperabile con un seek" 619 | 620 | "expected timestamp" 621 | 1 622 | "timestamp atteso" 623 | 624 | "detected timestamp" 625 | 1 626 | "timestamp rilevato" 627 | 628 | "too irregular timestamps not supported\n(more info in the guide)" 629 | 1 630 | "timestamp troppo irregolari non supportati\n(maggiori info nella guida)" 631 | 632 | "delay (ms): " 633 | 1 634 | "ritardo (ms): " 635 | 636 | "Import data from cfg" 637 | 1 638 | "Importa dati da cfg" 639 | 640 | "Select cfg" 641 | 1 642 | "Seleziona cfg" 643 | 644 | "View" 645 | 1 646 | "Visualizza" 647 | 648 | "Do you want to link these segments" 649 | 1 650 | "Vuoi collegare questi segmenti" 651 | 652 | "Same area" 653 | 1 654 | "Stessa area" 655 | 656 | "Same width" 657 | 1 658 | "Stessa larghezza" 659 | 660 | "Proportional" 661 | 1 662 | "Proporzionale" 663 | 664 | "Warning: one of the two movies\nmay have undergone a frame rate change" 665 | 1 666 | "Attenzione: uno dei due filmati potrebbe\naver subito un cambio di frame rate" 667 | 668 | "Export project data" 669 | 1 670 | "Esporta dati del progetto" 671 | 672 | "Export project data as..." 673 | 1 674 | "Esporta dati del progetto come..." 675 | 676 | "Project data successfully exported." 677 | 1 678 | "Dati del progetto esportati con successo." 679 | 680 | "Keyboard shortcuts" 681 | 1 682 | "Scorciatoie da tastiera" 683 | 684 | "The \"mapping\" data are already optimized." 685 | 1 686 | "I dati di \"mapping\" sono già ottimizzati." 687 | 688 | "The \"mapping\" data will be optimized." 689 | 1 690 | "I dati di \"mapping\" verranno ottimizzati." 691 | 692 | "Concurrency" 693 | 1 694 | "Concorrenza" 695 | 696 | "unrecognized audio format" 697 | 1 698 | "formato audio non riconosciuto" 699 | 700 | "Current number of threads" 701 | 1 702 | "Numero attuale di threads" 703 | 704 | "Max number of threads" 705 | 1 706 | "Numero massimo di threads" 707 | 708 | "Try to disable cuvid..." 709 | 1 710 | "Prova a disabilitare cuvid..." 711 | 712 | "Print buffers content" 713 | 1 714 | "Stampa il contenuto dei buffers" 715 | 716 | "hole" 717 | 1 718 | "buco" 719 | 720 | "holes" 721 | 1 722 | "buchi" 723 | 724 | "none" 725 | 1 726 | "nessuno" 727 | 728 | "Movements" 729 | 1 730 | "Spostamenti" 731 | 732 | "Undo the last movement" 733 | 1 734 | "Annulla l'ultimo spostamento" 735 | 736 | "The last movement will be undone." 737 | 1 738 | "L'ultimo spostamento verrà annullato." 739 | 740 | " link(s) will also be deleted." 741 | 1 742 | " link(s) verranno rimossi, inoltre." 743 | 744 | "Thanks to:" 745 | 1 746 | "Grazie a:" 747 | 748 | ) 749 | 750 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 751 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 752 | ;;;; ;;;; 753 | ;;;; ;;;; 754 | ;;;; ;;;; 755 | ;;;; ;;;; 756 | ;;;; ;;;; 757 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 758 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 759 | 760 | -------------------------------------------------------------------------------- /map.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defun map-create (n1 n2) net map-create) 12 | (defnet map-create (n1 n2 @map) 13 | (deflocal a1 a2) 14 | 15 | (integerp n1) 16 | (>= n1 1) 17 | (integerp n2) 18 | (>= n2 1) 19 | (set a1 (array 3)) 20 | (set 1) 21 | (set n1) 22 | (set a2 (array 3)) 23 | (set 1) 24 | (set n2) 25 | (set @map (cons (array default a1 1) 26 | (array default a2 1) ))) 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;;;; ;;;; 31 | ;;;; ;;;; 32 | ;;;; ;;;; 33 | ;;;; ;;;; 34 | ;;;; ;;;; 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (defun map-max1 (m) 39 | (map-max-low (car (match-map m))) ) 40 | 41 | (defun map-max2 (m) 42 | (map-max-low (cdr (match-map m))) ) 43 | 44 | (defun map-max-low (map) 45 | ) 46 | 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | ;;;; ;;;; 50 | ;;;; ;;;; 51 | ;;;; ;;;; 52 | ;;;; ;;;; 53 | ;;;; ;;;; 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | 57 | (defun map-free1 (m) 58 | (map-free-low (map-undef1 m)) ) 59 | 60 | (defun map-free2 (m) 61 | (map-free-low (map-undef2 m)) ) 62 | 63 | (defun map-free-low (u) net map-free-low) 64 | (defnet map-free-low (u @n) 65 | (deflocal ut) 66 | 67 | (set @n 0) 68 | (while (> (length u) 0) do 69 | (set ut (queue-get u)) 70 | (inc @n (- -1)) )) 71 | 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | ;;;; ;;;; 75 | ;;;; ;;;; 76 | ;;;; ;;;; 77 | ;;;; ;;;; 78 | ;;;; ;;;; 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | 82 | (defnet map-bind (m p q n) 83 | (array-append (match-map-step m) (list p q n)) 84 | (set m (match-map m)) 85 | (map-bind-low (car m) p q n) 86 | (map-bind-low (cdr m) q p n) ) 87 | 88 | (defnet map-bind-low (map p q n) 89 | (deflocal i j a aa freea freeb found) 90 | 91 | (for i in 0 .. (- (length map) 1) do 92 | (set a ) 93 | (set freea ) 94 | (set freeb ) 95 | (set found (in p freea .. freeb)) 96 | until found ) 97 | (truep found) 98 | (= undef) 99 | (set j (+ p n -1)) 100 | (in j freea .. freeb) 101 | (if (> p freea) 102 | then (set aa (array 3)) 103 | (set freea) 104 | (set (- p 1)) 105 | (array-insert map i aa) 106 | (inc i) ) 107 | (if (< j freeb) 108 | then (set aa (array 3)) 109 | (set (+ j 1)) 110 | (set freeb) 111 | (array-insert map (+ i 1) aa) ) 112 | (set p) 113 | (set j) 114 | (set q) 115 | (if (and (> i 0) 116 | (= p freea) 117 | (= (- ) 118 | (- q p) )) 119 | then (array-remove map i) 120 | (inc i -1) 121 | (set a ) 122 | (set j) 123 | (set p ) 124 | (set q ) ) 125 | (if (and (= j freeb) 126 | (= (- ) 127 | (- q p) )) 128 | then (set ) 129 | (array-remove map (+ i 1)) )) 130 | 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 | ;;;; ;;;; 134 | ;;;; ;;;; 135 | ;;;; ;;;; 136 | ;;;; ;;;; 137 | ;;;; ;;;; 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | 141 | (defun map-undef1 (m) 142 | (map-undef-low (car (match-map m)) (cdr (match-map m))) ) 143 | 144 | (defun map-undef2 (m) 145 | (map-undef-low (cdr (match-map m)) (car (match-map m))) ) 146 | 147 | (defun map-undef-low (map1 map2) 148 | (map-undef-low-low map1 map2 false) ) 149 | 150 | (defun map-undef-low-low (map1 map2 also-empty) net map-undef-low-low) 151 | (defnet map-undef-low-low (map1 map2 also-empty @q) 152 | (deflocal i a min max) 153 | 154 | (set @q (queue)) 155 | (set min 1) 156 | (for i in 1 .. (length map1) do 157 | (set a ) 158 | (if (= undef) 159 | then (set max (if (= i (length map1)) 160 | 161 | (- 1) )) 162 | (if (or also-empty (<= min max)) 163 | then (queue-put @q (list min max)) ) 164 | else (set min (+ - 1)) ))) 165 | 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | ;;;; ;;;; 169 | ;;;; ;;;; 170 | ;;;; ;;;; 171 | ;;;; ;;;; 172 | ;;;; ;;;; 173 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | 176 | (defun map-point1 (m p) 177 | (map-point-low (car (match-map m)) p) ) 178 | 179 | (defun map-point2 (m p) 180 | (map-point-low (cdr (match-map m)) p) ) 181 | 182 | (defun map-point-low (map p) net map-point-low) 183 | (defnet map-point-low (map p @q) 184 | (deflocal i a found) 185 | 186 | (set found false) 187 | (for i in 1 .. (length map) do 188 | (set a ) 189 | (if (in p .. ) 190 | then (set @q (+ p -)) 191 | (set found true) ) 192 | until found ) 193 | (= found true) ) 194 | 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | ;;;; ;;;; 198 | ;;;; ;;;; 199 | ;;;; ;;;; 200 | ;;;; ;;;; 201 | ;;;; ;;;; 202 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | 205 | (defnet map-report (m) 206 | (map-report-low (match-th-main m) (match-map m) 207 | (match-name1 m) (match-name2 m) 208 | (match-rx m) (match-ry m) 209 | (length (match-cache m)) (match-passed m) true )) 210 | 211 | (defnet map-report-low (target map name1 name2 rx ry nchecks npassed go-home) 212 | (deflocal buf buf2 ab map-max1 map-max2 wrn1 wrn2 u ut a p1 p2 q prv freecnt diffcnt diff diffprv i) 213 | 214 | (if (listp target) 215 | then (set ab (cdr target)) 216 | (set target (car target)) ) 217 | (set map-max1 (map-max-low (car map))) 218 | (set map-max2 (map-max-low (cdr map))) 219 | (set buf (iup-text-buffer)) 220 | (set buf2 (iup-text-buffer)) 221 | (map-report-print (cons "p1" (+ 222 | "(1) " name1 nl 223 | "(2) " name2 nl 224 | nl 225 | "free (1): " (map-free-low (map-undef-low (car map) (cdr map))) "/" map-max1 nl 226 | "free (2): " (map-free-low (map-undef-low (cdr map) (car map))) "/" map-max2 nl 227 | nl 228 | $"checks: " nchecks $" (passed: " npassed ")" nl 229 | (if (= rx undef) "" (+ 230 | $"horizontal ratio: " (approx3 rx) nl )) 231 | (if (= ry undef) "" (+ 232 | $"vertical ratio: " (approx3 ry) nl )))) buf ) 233 | (set wrn1 (queue)) 234 | (set wrn2 (queue)) 235 | (set u (map-undef-low (car map) (cdr map))) 236 | (set ut (queue-get u)) 237 | (set map (car map)) 238 | (set freecnt 0) 239 | (set diffcnt 0) 240 | (for i in 1 .. (length map) do 241 | (set a ) 242 | (set p1 ) 243 | (set p2 ) 244 | (set q ) 245 | (if (= q undef) 246 | then (if (and (= p1 ) (= p2 )) 247 | then (map-report-print-range p1 p2 (red) (blue) buf2) 248 | (map-report-print (cons "p1c" (cons (red) (+ " -/-> ???" " {" (- p2 p1 -1) "-" (- -1) "}" nl))) buf2) 249 | (if (arrayp ab) 250 | then (array-append ab (list p1 0) (list p2 0)) ) 251 | (set ut (queue-get u)) 252 | (inc freecnt) 253 | else (queue-put wrn1 (list p1 p2 (if (= prv undef) 0 prv))) ) 254 | (clr prv) 255 | else (if (integerp prv) 256 | then (queue-put wrn2 (list (+ prv 1) (- q 1) (- p1 1))) ) 257 | (set prv (+ q p2 -p1)) 258 | (set diff (- q p1)) 259 | (if (integerp diffprv) 260 | then (if (<> diff diffprv) 261 | then (inc diffcnt) )) 262 | (set diffprv diff) 263 | (map-report-print-range p1 p2 (darkgreen) (blue) buf2) 264 | (map-report-print (cons "p1c" (cons (darkgreen) (+ " ---> [" 265 | (int->str q 6 '0') "-" (int->str prv 6 '0') "] {" 266 | (int->str (- p2 p1 -1) 6 '0') "} (diff=" diff ")" nl))) buf2 ) 267 | (if (arrayp ab) 268 | then (if (= p1 p2) 269 | then (array-append ab (list p1 q 3)) 270 | else (array-append ab (list p1 q 1) (list p2 prv 2)) )) 271 | (if (and (= i 1) (= p1 1) (> q 1)) 272 | then (queue-put wrn2 (list 1 (- q 1) 0)) ) 273 | (if (and (= i (length map)) (= p2 map-max1) (< (+ q p2 -p1) map-max2)) 274 | then (queue-put wrn2 (list (+ q p2 -p1 1) map-max2 map-max1)) ))) 275 | (if (> (length wrn1) 0) 276 | then (map-report-print (cons "p1" $"\n1st movie frame(s) not found in the 2nd one:\n") buf2) 277 | (map-report-diff wrn1 buf2 0) ) 278 | (if (> (length wrn2) 0) 279 | then (map-report-print (cons "p1" $"\n2nd movie frame(s) not found in the 1st one:\n") buf2) 280 | (map-report-diff wrn2 buf2 1) ) 281 | (map-report-print (cons "p1" (+ "internal diff: " diffcnt nl 282 | "free segm: " freecnt nl 283 | nl )) buf ) 284 | (iup-text-buffer-cat buf buf2) 285 | (if (arrayp ab) 286 | then (gui-text1-hack true) 287 | (set target <_kv "text1">) 288 | (iup-text-buffer-flush buf target) 289 | (if go-home 290 | then (iup-set-int target "CARETPOS" 0) 291 | else (gui-text1-hack-post) ) 292 | else (sendbuf 100 (cons "bf1" buf) to target) 293 | (if go-home 294 | then (sendbuf 100 [ "h1" . undef ] to target) ))) 295 | 296 | (defnet map-report-diff (wrn buf which) 297 | (deflocal i) 298 | 299 | (while (> (length wrn) 0) do 300 | (set i (queue-get wrn)) 301 | (map-report-print-range (black) (blue) buf) 302 | (map-report-print (cons "p1" (+ <[ "¹" "²" ] which> "---> [" (int->str 6 '0') "] {" 303 | (- -1) "}" nl )) buf ))) 304 | 305 | (defnet map-report-print-range (p1 p2 color1 color2 buf) 306 | (map-report-print (cons "p1c" (cons color1 "[")) buf) 307 | (map-report-print (cons "p1c" (cons color2 (int->str p1 6 '0'))) buf) 308 | (map-report-print (cons "p1c" (cons color1 "-")) buf) 309 | (map-report-print (cons "p1c" (cons color2 (int->str p2 6 '0'))) buf) 310 | (map-report-print (cons "p1c" (cons color1 "]")) buf) ) 311 | 312 | (defnet map-report-print (msg buf) 313 | (deflocal req) 314 | 315 | (set req (car msg)) 316 | (set msg (cdr msg)) 317 | (case req of 318 | "p1" (iup-text-buffer-append buf msg) 319 | "p1c" (iup-text-buffer-append-color buf (car msg) (cdr msg)) )) 320 | 321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 322 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 323 | ;;;; ;;;; 324 | ;;;; ;;;; 325 | ;;;; ;;;; 326 | ;;;; ;;;; 327 | ;;;; ;;;; 328 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 329 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 330 | 331 | -------------------------------------------------------------------------------- /match.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet match (th-main name1 name2 av1 av2 scd1 scd2 pix default-info) 12 | (deflocal m scd-min-blocks scd-min-avg-block-size thres1 thres2 thres avg1 avg2 alternate i j) 13 | 14 | (pix-wip pix) 15 | (opt (gui-draw-image-th th-main)) 16 | 17 | (set scd-min-blocks (cfg-get-or-default-num "scd-min-blocks" default-info)) 18 | (set scd-min-avg-block-size (cfg-get-or-default-num "scd-min-avg-block-size" default-info)) 19 | 20 | (set m (match-create name1 name2 av1 av2 scd1 scd2 th-main pix default-info)) 21 | (set i (map-free1 m)) 22 | (map-report m) 23 | 24 | (set avg1 (array-avg scd1)) 25 | (set avg2 (array-avg scd2)) 26 | 27 | (for alternate in [ false true ] do 28 | (if alternate 29 | then (msg-log m "\n\n\nstarting alternate strategies\n\n\n") ) 30 | (set thres (match-params m "init-scd-threshold")) 31 | (while (>= thres (match-params m "min-scd-threshold")) do 32 | (set thres1 (* avg1 thres)) 33 | (set thres2 (* avg2 thres)) 34 | (repeat (msg-log m (+ "begin match-step: " (approx3 thres1) "-" (approx3 thres2) nl)) 35 | (set j i) 36 | (match-step false alternate false m thres1 thres2 scd-min-blocks scd-min-avg-block-size) 37 | until (match-abort m) 38 | (set i (map-free1 m)) 39 | (msg-log m (+ "end match-step: " (approx3 thres1) "-" (approx3 thres2) " -> " (- j i) nl)) 40 | until (= i j) ) 41 | until (match-abort m) 42 | (set thres (* thres (match-params m "scd-threshold-ratio"))) ) 43 | until (match-abort m) ) 44 | 45 | (if (and (not (match-abort m)) (cfg-get-or-default "final-closure" default-info)) 46 | then (match-step false true true m thres1 thres2 scd-min-blocks scd-min-avg-block-size) ) 47 | 48 | (match-destroy m true) ) 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | ;;;; ;;;; 53 | ;;;; ;;;; 54 | ;;;; ;;;; 55 | ;;;; ;;;; 56 | ;;;; ;;;; 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | (defnet match-step (ignore-false alternate final-closure m thres1 thres2 scd-min-blocks scd-min-avg-block-size) 61 | (deflocal u ut a1 a2 p1a p1b p2a p2b 62 | best-p2 best-d1 best-d2 n mdb segfirst seglast bound ) 63 | 64 | (set u (map-undef1 m)) 65 | (while (> (length u) 0) do 66 | (set ut (queue-get u)) 67 | (set segfirst (= 1)) 68 | (set seglast (= (map-max1 m))) 69 | (set bound 0) 70 | (set a1 (seq-threshold (match-scd1 m) thres1)) 71 | (set a2 (seq-threshold (match-scd2 m) thres2)) 72 | (set p1a 0) 73 | (set p1b (- (length a1) 1)) 74 | (set p2a 0) 75 | (set p2b (- (length a2) 1)) 76 | (while (and (<= p1a p1b) (not (match-abort m))) do 77 | (alt (match-receivenb m) 78 | (seq (match-best ignore-false a1 a2 p1a p1b p2a p2b best-p2 best-d1 best-d2 n) 79 | (set mdb (/ n (max best-d1 best-d2))) 80 | (>= mdb 8) 81 | (or (and (>= (min best-d1 best-d2) scd-min-blocks) 82 | (>= mdb scd-min-avg-block-size) ) 83 | (and (= p1a 0) (= best-p2 p2a) (not segfirst)) 84 | (and (> (+ p1a best-d1) p1b) (> (+ best-p2 best-d2) p2b) (not seglast)) ) 85 | (match-check-and-bind alternate m (cdr ) (cdr ) n) 86 | (inc bound n) 87 | (inc p1a best-d1) 88 | (set p2a (+ best-p2 best-d2)) ) 89 | (inc p1a) )) 90 | (if (and alternate (= bound 0) (not (match-abort m))) 91 | then (match-step-alternate final-closure m ut a1 a2 segfirst seglast) ))) 92 | 93 | (defnet match-step-alternate (final-closure m ut a1 a2 segfirst seglast) 94 | (deflocal p1a p2a p1b p2b size1 size2 n n1 n2 score1 score2) 95 | 96 | (set p1a ) 97 | (set p2a ) 98 | (set p1b (- (length a1) 1)) 99 | (set p2b (- (length a2) 1)) 100 | (set size1 (- p1a -1)) 101 | (set size2 (- p2a -1)) 102 | (set n (min size1 size2)) 103 | (set n1 (min (car ) (car ))) 104 | (set n2 (min (car ) (car ))) 105 | (alt (seq (= size1 size2) 106 | (if final-closure 107 | then (msg-log m (+ "\nfinal closure: [" 108 | (int->str p1a 6 '0') "-" (int->str (+ p1a n -1) 6 '0') 109 | "] <-> [" 110 | (int->str p2a 6 '0') "-" (int->str (+ p2a n -1) 6 '0') 111 | "] (" n ")" nl )) 112 | (map-bind m p1a p2a n) 113 | (map-report m) 114 | else (match-check-and-bind true m p1a p2a n) )) 115 | 116 | (truep (match-abort m)) 117 | 118 | (seq (not segfirst) 119 | (not seglast) 120 | ; (> (+ n1 n2) n) ; si puo` fare meglio? 121 | (match-check true m p1a p2a n1 score1) 122 | (match-check true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2 score2) 123 | 124 | (msg-log m (+ "conflicting strategies: " (approx3 score1) " vs " (approx3 score2) nl)) 125 | 126 | (if (>= (abs (- score1 score2)) 0.03) 127 | then (msg-log m (+ "done" nl)) 128 | (if (> score1 score2) 129 | then (match-check-and-bind true m p1a p2a n1) 130 | else (match-check-and-bind true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2) ))) 131 | 132 | (truep (match-abort m)) 133 | 134 | (seq (not segfirst) 135 | (match-check true m p1a p2a n1 score1) 136 | (> score1 0) 137 | (match-check-and-bind true m p1a p2a n1) ) 138 | 139 | (truep (match-abort m)) 140 | 141 | (seq (not seglast) 142 | (match-check true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2 score2) 143 | (> score2 0) 144 | (match-check-and-bind true m (+ p1a size1 -n2) (+ p2a size2 -n2) n2) ) 145 | 146 | (success) )) 147 | 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | ;;;; ;;;; 151 | ;;;; ;;;; 152 | ;;;; ;;;; 153 | ;;;; ;;;; 154 | ;;;; ;;;; 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | 158 | (defnet match-best (ignore-false a1 a2 p1 p1b p2a p2b @best-p2 @best-d1 @best-d2 @best-n) 159 | (deflocal d1 d2 x1 x2 n i done ab1 ab2) 160 | 161 | (set ab1 true) 162 | (set ab2 true) 163 | (set @best-d1 0) 164 | (while (<= p2a p2b) do 165 | (set d1 p1) 166 | (set d2 p2a) 167 | (set n 0) 168 | (repeat (set x1 (car )) 169 | (set x2 (car )) 170 | (if (= x1 x2) 171 | then (inc d1) 172 | (inc d2) 173 | (inc n x1) 174 | (set done false) 175 | else (if ignore-false 176 | then (alt (seq (= ab1 true) 177 | (match-best-ignore-false x1 a2 d2 p2b i) 178 | (inc d1) 179 | (inc d2 i) 180 | (inc n x1) 181 | (set ab2 false) 182 | (set done false) ) 183 | (seq (= ab2 true) 184 | (match-best-ignore-false x2 a1 d1 p1b i) 185 | (inc d1 i) 186 | (inc d2) 187 | (inc n x2) 188 | (set ab1 false) 189 | (set done false) ) 190 | (set done true) ) 191 | else (set done true) )) 192 | until done 193 | until (> d1 p1b) 194 | until (> d2 p2b) ) 195 | (inc d1 -p1) 196 | (if (> d1 @best-d1) 197 | then (set @best-p2 p2a) 198 | (set @best-d1 d1) 199 | (set @best-d2 (- d2 p2a)) 200 | (set @best-n n) ) 201 | (inc p2a) ) 202 | (> @best-d1 0) ) 203 | 204 | (defnet match-best-ignore-false (target a p1 p2 @n) 205 | (deflocal sum) 206 | 207 | (set sum 0) 208 | (set @n 0) 209 | (repeat (inc sum (car )) 210 | (<= sum target) 211 | (inc @n) 212 | until (= sum target) 213 | (< p1 p2) 214 | (inc p1) )) 215 | 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 218 | ;;;; ;;;; 219 | ;;;; ;;;; 220 | ;;;; ;;;; 221 | ;;;; ;;;; 222 | ;;;; ;;;; 223 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 224 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 225 | 226 | (defnet match-check (alternate m p1 p2 n @score) 227 | (deflocal step cnt score i j) 228 | 229 | (set step (max 1 (/ (- n 1) 230 | (- (+ (match-params m "checks-per-interval") 231 | (if alternate (match-params m "checks-per-interval-extra") 0) ) 232 | 1 )))) 233 | (set @score 0) 234 | (set cnt 0) 235 | (set i 0) 236 | (repeat (set j (rint i)) 237 | (sift-check alternate m (+ p1 j) (+ p2 j) score) 238 | (if (> score 0) 239 | then (inc cnt) 240 | (inc @score score) ) 241 | until (= i (- n 1)) 242 | (inc i step) ) 243 | (if (> cnt 0) 244 | then (set @score (/ @score cnt)) )) 245 | 246 | (defnet match-check-and-bind (alternate m p1 p2 n) 247 | (deflocal score) 248 | 249 | (msg-log m (+ "\ninterval to check: [" 250 | (int->str p1 6 '0') "-" (int->str (+ p1 n -1) 6 '0') 251 | "] <-> [" 252 | (int->str p2 6 '0') "-" (int->str (+ p2 n -1) 6 '0') 253 | "] (" n ")" nl )) 254 | 255 | (match-check alternate m p1 p2 n score) 256 | (map-bind m p1 p2 n) 257 | (map-report m) 258 | 259 | (msg-log m (+ "\ninterval accepted: [" 260 | (int->str p1 6 '0') "-" (int->str (+ p1 n -1) 6 '0') 261 | "] <-> [" 262 | (int->str p2 6 '0') "-" (int->str (+ p2 n -1) 6 '0') 263 | "] (" n ")" nl ))) 264 | 265 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 266 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 267 | ;;;; ;;;; 268 | ;;;; ;;;; 269 | ;;;; ;;;; 270 | ;;;; ;;;; 271 | ;;;; ;;;; 272 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 273 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 274 | 275 | (defun match-create (name1 name2 av1 av2 scd1 scd2 th-main pix default-info) net match-create) 276 | (defnet match-create (name1 name2 av1 av2 scd1 scd2 th-main pix default-info @m) 277 | (deflocal frm1 frm2 pix1 pix2 k params v) 278 | 279 | (set params (assoc)) 280 | (for k in [ "init-scd-threshold" 281 | "min-scd-threshold" 282 | "scd-threshold-ratio" 283 | "checks-per-interval" 284 | "checks-per-interval-extra" 285 | "min-keypoints" 286 | "min-keypoints-min-ratio" 287 | "min-keypoints-min-ratio-lum" 288 | "sift-match-threshold-val" 289 | "sift-match-threshold-min-ratio" 290 | "sift-agreements-min" 291 | "sift-proportionality-threshold" 292 | "filter-gamma1" 293 | "filter-gamma2" 294 | ] do 295 | (set (cfg-get-or-default-num k default-info)) ) 296 | (for k in [ "filter-mirror1" 297 | "filter-flip1" 298 | "filter-mirror2" 299 | "filter-flip2" 300 | "sift-draw-lines" 301 | ] do 302 | (set (cfg-get-or-default k default-info)) ) 303 | (set pix1 (cfg-get-or-default "sift-scale" default-info)) 304 | (set pix2 (cfg-get-or-default-num "sift-scale-pixels" default-info)) 305 | (set frm1 (match-create-frm 1 av1 pix1 pix2)) 306 | (set frm2 (match-create-frm 2 av2 pix1 pix2)) 307 | (set k (min (/ (- (width pix) (* 2 (space))) (max (width frm1) (width frm2))) 308 | (/ (- (height pix) (* 3 (space))) (+ (height frm1) (height frm2))) )) 309 | (set pix1 (pix-create (* k (width frm1)) (* k (height frm1)))) 310 | (set pix2 (pix-create (* k (width frm2)) (* k (height frm2)))) 311 | (set @m (array 26)) 312 | (set k (cfg-get (key-sck av1 av2 name1 name2))) 313 | (if (<> k undef) 314 | then (set <@m 0> ) 315 | (set <@m 1> ) 316 | (set <@m 6> ) 317 | (set <@m 7> ) 318 | (set <@m 8> ) 319 | (set <@m 9> ) 320 | (if (= (length k) 8) 321 | then (set <@m 23> ) 322 | (set <@m 24> ) 323 | else ; FIXME qui andrebbero ricalcolate le luminosità 324 | ; dei frame che hanno un res intero 325 | (set <@m 23> 0) 326 | (set <@m 24> 0) ) 327 | else (set <@m 0> (assoc)) 328 | (set <@m 1> 0) 329 | (set <@m 6> 0) 330 | (set <@m 7> 0) 331 | (set <@m 8> 0) 332 | (set <@m 9> 0) 333 | (set <@m 23> 0) 334 | (set <@m 24> 0) ) 335 | (set <@m 2> av1) 336 | (set <@m 3> av2) 337 | (set <@m 4> frm1) 338 | (set <@m 5> frm2) 339 | (set <@m 10> (map-create (- (length scd1) 1) (- (length scd2) 1))) 340 | (set <@m 11> th-main) 341 | (set <@m 12> (thread-create (netptr th-sift-features) 342 | (thread-self) frm1 )) 343 | (set <@m 13> (thread-create (netptr th-sift-features) 344 | (thread-self) frm2 )) 345 | (set <@m 14> name1) 346 | (set <@m 15> name2) 347 | (set <@m 16> pix1) 348 | (set <@m 17> pix2) 349 | (set <@m 18> pix) 350 | (set <@m 19> (array 0)) 351 | (set <@m 20> scd1) 352 | (set <@m 21> scd2) 353 | (set <@m 22> params) 354 | (set <@m 25> false) 355 | (set k (cfg-get (key-map av1 av2 name1 name2))) 356 | (if (<> k undef) 357 | then (for k in do 358 | (map-bind @m ) ))) 359 | 360 | (defun match-create-frm (which av sift-scale sift-scale-pixels) net match-create-frm) 361 | (defnet match-create-frm (which av sift-scale sift-scale-pixels @frm) 362 | (deflocal w h k) 363 | 364 | (set w (* (width av) (my-av-par which av))) 365 | (set h (height av)) 366 | (if sift-scale 367 | then (set k (sqrt (/ (* w h) sift-scale-pixels))) 368 | (set w (/ w k)) 369 | (set h (/ h k)) ) 370 | (set @frm (pix-create (rint w) (rint h))) ) 371 | 372 | (defnet match-destroy (m store) 373 | (close (match-frm1 m) (match-frm2 m) (match-pix1 m) (match-pix2 m)) 374 | (if store 375 | then (cfg-set (key-sck (match-av1 m) (match-av2 m) 376 | (match-name1 m) (match-name2 m) ) 377 | (list (match-cache m) (match-passed m) 378 | )) 379 | (cfg-set (key-map (match-av1 m) (match-av2 m) 380 | (match-name1 m) (match-name2 m) ) 381 | (list (- (length (match-scd1 m)) 1) 382 | (- (length (match-scd2 m)) 1) 383 | (match-map-step m) ))) 384 | (send undef to (match-th-sift1 m)) 385 | (send undef to (match-th-sift2 m)) 386 | (thread-join (match-th-sift1 m)) 387 | (thread-join (match-th-sift2 m)) 388 | (not (match-abort m)) ) 389 | 390 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 391 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 392 | ;;;; ;;;; 393 | ;;;; ;;;; 394 | ;;;; ;;;; 395 | ;;;; ;;;; 396 | ;;;; ;;;; 397 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 398 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 399 | 400 | (defnet match-receivenb (m) 401 | (truep <_abort 0>) 402 | (match-abort m) ) 403 | 404 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 405 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 406 | ;;;; ;;;; 407 | ;;;; ;;;; 408 | ;;;; ;;;; 409 | ;;;; ;;;; 410 | ;;;; ;;;; 411 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 412 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 413 | 414 | (defun match-cache (m) ) 415 | (defun match-passed (m) ) 416 | (defun match-av1 (m) ) 417 | (defun match-av2 (m) ) 418 | (defun match-frm1 (m) ) 419 | (defun match-frm2 (m) ) 420 | (defun match-rx (m) (/ )) 421 | (defun match-ry (m) (/ )) 422 | (defun match-width1 (m) (width (match-av1 m))) 423 | (defun match-height1 (m) (height (match-av1 m))) 424 | (defun match-width2 (m) (width (match-av2 m))) 425 | (defun match-height2 (m) (height (match-av2 m))) 426 | (defun match-hcorrection (m) 427 | (/ (/ (match-width2 m) (width (match-frm2 m))) 428 | (/ (match-width1 m) (width (match-frm1 m))) )) 429 | (defun match-vcorrection (m) 430 | (/ (/ (match-height2 m) (height (match-frm2 m))) 431 | (/ (match-height1 m) (height (match-frm1 m))) )) 432 | (defun match-map (m) ) 433 | (defun match-th-main (m) ) 434 | (defun match-th-sift1 (m) ) 435 | (defun match-th-sift2 (m) ) 436 | (defun match-name1 (m) ) 437 | (defun match-name2 (m) ) 438 | (defun match-pix1 (m) ) 439 | (defun match-pix2 (m) ) 440 | (defun match-pix (m) ) 441 | (defun match-map-step (m) ) 442 | (defun match-scd1 (m) ) 443 | (defun match-scd2 (m) ) 444 | (defun match-params (m key) ) 445 | (defun match-abort (m) ) 446 | (defnet match-abort (m) (set true)) 447 | 448 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 449 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 450 | ;;;; ;;;; 451 | ;;;; ;;;; 452 | ;;;; ;;;; 453 | ;;;; ;;;; 454 | ;;;; ;;;; 455 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 456 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 457 | 458 | -------------------------------------------------------------------------------- /move-scd.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet move-scd-left1-cb (self) 12 | (move-scd-low 1 true) ) 13 | 14 | (defnet move-scd-right1-cb (self) 15 | (move-scd-low 1 false) ) 16 | 17 | (defnet move-scd-left2-cb (self) 18 | (move-scd-low 2 true) ) 19 | 20 | (defnet move-scd-right2-cb (self) 21 | (move-scd-low 2 false) ) 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | ;;;; ;;;; 26 | ;;;; ;;;; 27 | ;;;; ;;;; 28 | ;;;; ;;;; 29 | ;;;; ;;;; 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (defnet move-scd-low (which left) 34 | (opt (move-scd-low-low which left)) ) 35 | 36 | (defnet move-scd-low-low (which left) 37 | (deflocal av scd thres o n) 38 | 39 | (gui-not-locked) 40 | (set av <_kv (+ "av" which)>) 41 | (if (or (= which 1) (= <_kv "prm"> undef)) 42 | then (set scd (cfg-get (key-scd av (fullpath->name <_kv (+ "path" which)>)))) 43 | (listp scd) 44 | (set scd ) 45 | else (set scd (cdr (cfg-get (key-prm <_kv "av1"> <_kv "av2"> (fullpath->name <_kv "path1">) (fullpath->name <_kv "path2">))))) 46 | (<> scd undef) ) 47 | (set thres (iup-text-spin-ratio-val <_kv (+ "scd-spin" which)>)) 48 | (set o (gui-spin-value which)) 49 | (if left 50 | then (for n in 1 .. (- o 1) rev do 51 | (if (>= thres) 52 | then (gui-spin-set-value which n) 53 | (gui-update-image) 54 | (fail) )) 55 | else (for n in (+ o 1) .. (- (av-approximated-number-of-frames av) 2) do 56 | (if (>= thres) 57 | then (gui-spin-set-value which n) 58 | (gui-update-image) 59 | (fail) )))) 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | ;;;; ;;;; 64 | ;;;; ;;;; 65 | ;;;; ;;;; 66 | ;;;; ;;;; 67 | ;;;; ;;;; 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | 71 | -------------------------------------------------------------------------------- /move-slide.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet move-slide-changed1-cb (self) 12 | (move-slide-changed self 1) ) 13 | 14 | (defnet move-slide-changed2-cb (self) 15 | (move-slide-changed self 2) ) 16 | 17 | (defnet move-slide-changed (self which) 18 | (deflocal v vmax kf) 19 | 20 | (opt (gui-not-locked) 21 | (set v (iup-get-double self "VALUE")) 22 | (if (<= v 0.025) 23 | then (set v 1) 24 | else (set vmax (iup-get-int <_kv (+ "spin" which)> "SPINMAX")) 25 | (set v (rint (linear v 0 1 1 vmax))) 26 | (set kf (av-nearest-keyframe <_kv (+ "av" which)> v (div vmax 500))) 27 | (if (integerp kf) 28 | then (set v (max 1 kf)) )) 29 | (gui-spin-set-value which v) 30 | (gui-update-image) )) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;;; ;;;; 35 | ;;;; ;;;; 36 | ;;;; ;;;; 37 | ;;;; ;;;; 38 | ;;;; ;;;; 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | 42 | -------------------------------------------------------------------------------- /move-spin.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet move-spin1-cb (self v) 12 | (move-spin-low 1 self v) ) 13 | 14 | (defnet move-spin2-cb (self v) 15 | (move-spin-low 2 self v) ) 16 | 17 | (defnet move-spin-low (which self v) 18 | (deflocal vv) 19 | 20 | (set vv (gui-spin-value which)) 21 | (if (<> v vv) 22 | then (if (gui-locked) 23 | then (iup-set-int self "SPINVALUE" vv) 24 | else (iup-set-str-attribute self "VALUE" v) 25 | (gui-update-image) ))) 26 | 27 | (defnet move-spin-kb1-cb (self c) 28 | (move-spin-kb-low 1 self c) ) 29 | 30 | (defnet move-spin-kb2-cb (self c) 31 | (move-spin-kb-low 2 self c) ) 32 | 33 | (defnet move-spin-kb-low (which self c) 34 | (alt (gui-locked) 35 | (or (= <_kv "av1"> undef) (= <_kv "av2"> undef)) 36 | (seq (= c (cmacro K_CR)) 37 | (move-spin-shortcut-low which self 0) ) 38 | (seq (= c (cmacro K_sUP)) 39 | (move-spin-shortcut-low which self 10) ) 40 | (seq (= c (cmacro K_sDOWN)) 41 | (move-spin-shortcut-low which self -10) ) 42 | (seq (= c (cmacro K_TAB)) 43 | (opt (gui-sync-low which false)) ))) 44 | 45 | (defnet move-spin-shortcut-low (which spin incr) 46 | (opt (gui-spin-set-value which (+ (gui-spin-value which) incr)) 47 | (gui-update-image) )) 48 | 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;;;; ;;;; 52 | ;;;; ;;;; 53 | ;;;; ;;;; 54 | ;;;; ;;;; 55 | ;;;; ;;;; 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | -------------------------------------------------------------------------------- /move-sync.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet move-sync-left-cb (self) 12 | (deflocal n1 n2 lm rm left right) 13 | 14 | (opt (movie-sync-pre n1 n2 lm rm left right) 15 | (not lm) 16 | (if (= left 0) 17 | then (sound-pop) ) 18 | (move-sync-post n1 n2 -1) )) 19 | 20 | (defnet move-sync-right-cb (self) 21 | (deflocal n1 n2 lm rm left right) 22 | 23 | (opt (movie-sync-pre n1 n2 lm rm left right) 24 | (not rm) 25 | (if (= right 0) 26 | then (sound-pop) ) 27 | (move-sync-post n1 n2 1) )) 28 | 29 | (defnet move-sync-left-fast-cb (self) 30 | (deflocal n1 n2 lm rm left right n) 31 | 32 | (opt (movie-sync-pre n1 n2 lm rm left right) 33 | (not lm) 34 | (if (= left 0) 35 | then (sound-pop) 36 | (set n -1) 37 | else (set n (max -(cfg-get-or-default-num "supervision-skip-double" <_kv "default">) left)) ) 38 | (move-sync-post n1 n2 n) )) 39 | 40 | (defnet move-sync-right-fast-cb (self) 41 | (deflocal n1 n2 lm rm left right n) 42 | 43 | (opt (movie-sync-pre n1 n2 lm rm left right) 44 | (not rm) 45 | (if (= right 0) 46 | then (sound-pop) 47 | (set n 1) 48 | else (set n (min (cfg-get-or-default-num "supervision-skip-double" <_kv "default">) right)) ) 49 | (move-sync-post n1 n2 n) )) 50 | 51 | (defnet move-sync-left-first-cb (self) 52 | (deflocal n1 n2 lm rm left right) 53 | 54 | (opt (movie-sync-pre n1 n2 lm rm left right) 55 | (not lm) 56 | (move-sync-post n1 n2 left) )) 57 | 58 | (defnet move-sync-right-last-cb (self) 59 | (deflocal n1 n2 lm rm left right) 60 | 61 | (opt (movie-sync-pre n1 n2 lm rm left right) 62 | (not rm) 63 | (move-sync-post n1 n2 right) )) 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | ;;;; ;;;; 68 | ;;;; ;;;; 69 | ;;;; ;;;; 70 | ;;;; ;;;; 71 | ;;;; ;;;; 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | (defnet movie-sync-pre (@n1 @n2 @left-is-min @right-is-max @left @right) 76 | (deflocal k n1 n2 map p q n i1 i2) 77 | 78 | (gui-not-locked) 79 | (set k (cfg-get (key-map <_kv "av1"> 80 | <_kv "av2"> 81 | (fullpath->name <_kv "path1">) 82 | (fullpath->name <_kv "path2">) ))) 83 | (<> k undef) 84 | (set @n1 (gui-spin-value 1)) 85 | (set @n2 (gui-spin-value 2)) 86 | (set @left-is-min (or (= @n1 1) (= @n2 1))) 87 | (set @right-is-max (or (= @n1 ) (= @n2 ))) 88 | (set map (map-create )) 89 | (for i1 in do 90 | (set p ) 91 | (set q ) 92 | (set n ) 93 | (map-bind-low (car map) p q n) 94 | (map-bind-low (cdr map) q p n) ) 95 | (for i1 in (car map) do 96 | until (in @n1 .. ) ) 97 | (for i2 in (cdr map) do 98 | until (in @n2 .. ) ) 99 | (set @left (max (- @n1) (- @n2))) 100 | (set @right (min (- @n1) (- @n2))) ) 101 | 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;;; ;;;; 105 | ;;;; ;;;; 106 | ;;;; ;;;; 107 | ;;;; ;;;; 108 | ;;;; ;;;; 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | (defnet move-sync-post (n1 n2 n) 113 | (gui-spin-set-value 1 (+ n1 n)) 114 | (gui-spin-set-value 2 (+ n2 n)) 115 | (gui-update-image) ) 116 | 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | ;;;; ;;;; 120 | ;;;; ;;;; 121 | ;;;; ;;;; 122 | ;;;; ;;;; 123 | ;;;; ;;;; 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | 127 | -------------------------------------------------------------------------------- /open.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet open-common (which path) 12 | (open-common-low which path true) ) 13 | 14 | (defnet open-common-low (which path warning) 15 | (deflocal default-info cuvid av av1 av2 name1 name2 n p i) 16 | 17 | (set default-info <_kv "default">) 18 | (set cuvid (cfg-get-or-default "cuvid-enabled" default-info)) 19 | (set av (if cuvid 20 | (av-avformat-open-input-cuvid path) 21 | (av-avformat-open-input path) )) 22 | (if (= av undef) 23 | then (if cuvid 24 | then (set av (av-avformat-open-input path)) 25 | (if (<> av undef) 26 | then (close av) 27 | (iup-warning60 <_kv "dlg"> $"Try to disable cuvid...") )) 28 | (fail) ) 29 | (alt (seq (set n (av-video-frame-rate av)) 30 | (rationalp n) 31 | (> n 0) 32 | (set n (av-approximated-number-of-frames av)) 33 | (integerp n) 34 | (>= n 3) ) 35 | (seq (close av) 36 | (fail) )) 37 | (av-set-buf-size av (cfg-get-or-default-num "frame-buf-size" default-info)) 38 | (set <_kv (+ "path" which)> path) 39 | (close <_kv (+ "av" which)>) 40 | (set <_kv (+ "av" which)> av) 41 | (gui-spin-set-value which 1) 42 | (iup-set-int <_kv (+ "spin" which)> "SPINMAX" (- n 2)) 43 | (av-set-filter-rows av (cfg-get-or-default-num (+ "filter-rows" which) default-info)) 44 | (opt (set n (cfg-get-or-default-num (+ "filter-deint" which) default-info)) 45 | (> n 0) 46 | (av-set-filter av <(deint-filters) n>) ) 47 | 48 | (set av1 <_kv "av1">) 49 | (set av2 <_kv "av2">) 50 | (set name1 (fullpath->name <_kv "path1">)) 51 | (set name2 (fullpath->name <_kv "path2">)) 52 | 53 | (assoc-clr _kv "prm") 54 | (opt (<> av1 undef) 55 | (<> av2 undef) 56 | (set n (cfg-get (key-prm av1 av2 name1 name2))) 57 | (<> n undef) 58 | (set p (perm-identity <(cfg-get (key-map av1 av2 name1 name2)) 1>)) 59 | (for i in (car n) do 60 | (set p (perm-move p )) ) 61 | (set <_kv "prm"> p) ) 62 | 63 | (gui-print-info-on-selected-file which) 64 | (opt (truep warning) 65 | (<> av1 undef) 66 | (<> av2 undef) 67 | (or (and (< (av-video-frame-rate av1) 25.5) (> (av-video-frame-rate av2) 27.5)) 68 | (and (< (av-video-frame-rate av2) 25.5) (> (av-video-frame-rate av1) 27.5)) ) 69 | (iup-text-append-and-go-end-color <_kv "text2"> (red) (+ 70 | $"Warning: one of the two movies\nmay have undergone a frame rate change" 71 | nl nl )))) 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | ;;;; ;;;; 76 | ;;;; ;;;; 77 | ;;;; ;;;; 78 | ;;;; ;;;; 79 | ;;;; ;;;; 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | 83 | (defnet open1-cb (self) 84 | (open-low self 1) ) 85 | 86 | (defnet open2-cb (self) 87 | (open-low self 2) ) 88 | 89 | (defnet open-low (self which) 90 | (deflocal path) 91 | 92 | (opt (set path (iup-choose-file-open self (+ $"Select movie " which) (cfg-get "path") undef true)) 93 | (stringp path) 94 | (cfg-set "path" path) 95 | (alt (open-common which path) 96 | (seq (sound-iup-error60 self (+ path $": movie not supported")) 97 | (fail) )) 98 | (opt (sqlite3-exec _db undef 99 | "INSERT INTO paths VALUES('" 100 | (sqlite3-escape-strings path) "','" 101 | (sqlite3-escape-strings (fullpath->name path)) "')" )) 102 | (gui-report) 103 | (gui-update-image) 104 | (gui-update) )) 105 | 106 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | ;;;; ;;;; 109 | ;;;; ;;;; 110 | ;;;; ;;;; 111 | ;;;; ;;;; 112 | ;;;; ;;;; 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | 116 | (defnet open-path1-cb (self) 117 | (open-path-low self 1) ) 118 | 119 | (defnet open-path2-cb (self) 120 | (open-path-low self 2) ) 121 | 122 | (defnet open-path-low (self which) 123 | (deflocal a i path) 124 | 125 | (opt (set a (cons (queue) (queue))) 126 | (sqlite3-exec-data _db (netptr open-path-cback) a 127 | "SELECT path,name FROM paths ORDER BY path" ) 128 | (if (= (length (cdr a)) 0) 129 | then (iup-warning60 self $"There are no valid paths.") 130 | (fail) ) 131 | (set i (iup-choose-menu (cdr a))) 132 | (integerp i) 133 | (set path <(car a) i>) 134 | (alt (open-common which path) 135 | (seq (sound-iup-error60 self (+ path $": movie not supported")) 136 | (fail) )) 137 | (cfg-set "path" path) 138 | (gui-report) 139 | (gui-update-image) 140 | (gui-update) )) 141 | 142 | (defnet open-path-cback (a path name) 143 | (if (pathexists path) 144 | then (queue-put (car a) path) 145 | (queue-put (cdr a) name) )) 146 | 147 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | ;;;; ;;;; 150 | ;;;; ;;;; 151 | ;;;; ;;;; 152 | ;;;; ;;;; 153 | ;;;; ;;;; 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | -------------------------------------------------------------------------------- /permute.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defun perm-identity (n) net perm-identity) 12 | (defnet perm-identity (n @p) 13 | (deflocal i) 14 | 15 | (set @p (array (+ n 1))) 16 | (for i in 0 .. n do 17 | (set <@p i> i) )) 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; ;;;; 22 | ;;;; ;;;; 23 | ;;;; ;;;; 24 | ;;;; ;;;; 25 | ;;;; ;;;; 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (defun perm-max (p) 30 | (- (length p) 1) ) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;;; ;;;; 35 | ;;;; ;;;; 36 | ;;;; ;;;; 37 | ;;;; ;;;; 38 | ;;;; ;;;; 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | 42 | (defun perm-inverse (p) net perm-inverse) 43 | (defnet perm-inverse (p @q) 44 | (deflocal n i) 45 | 46 | (set n (perm-max p)) 47 | (set @q (array (+ n 1))) 48 | (for i in 0 .. n do 49 | (set <@q

> i) )) 50 | 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | ;;;; ;;;; 54 | ;;;; ;;;; 55 | ;;;; ;;;; 56 | ;;;; ;;;; 57 | ;;;; ;;;; 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | 61 | (defun perm-mult (p q) net perm-mult) 62 | (defnet perm-mult (p q @r) 63 | (deflocal n i) 64 | 65 | (set n (perm-max p)) 66 | (= n (perm-max q)) 67 | (set @r (array (+ n 1))) 68 | (for i in 0 .. n do 69 | (set <@r i>

>) )) 70 | 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | ;;;; ;;;; 74 | ;;;; ;;;; 75 | ;;;; ;;;; 76 | ;;;; ;;;; 77 | ;;;; ;;;; 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | (defun perm-move (p src dst k) net perm-move) 82 | (defnet perm-move (p src dst k @q) 83 | (deflocal n dst-max i j l) 84 | 85 | (set n (perm-max p)) 86 | (<= src n) 87 | (<= dst n) 88 | (<= k (- n (max src dst) -1)) 89 | (set dst-max (+ dst k -1)) 90 | (set @q (array (+ n 1))) 91 | (set j 0) 92 | (set l src) 93 | (for i in 0 .. n do 94 | (if (in i dst .. dst-max) 95 | then (set <@q i>

) 96 | (inc l) 97 | else (if (= j src) 98 | then (inc j k) ) 99 | (set <@q i>

) 100 | (inc j) ))) 101 | 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;;; ;;;; 105 | ;;;; ;;;; 106 | ;;;; ;;;; 107 | ;;;; ;;;; 108 | ;;;; ;;;; 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | (defun perm-random-move (p) net perm-random-move) 113 | (defnet perm-random-move (p @m) 114 | (deflocal n src dst k) 115 | 116 | (set n (perm-max p)) 117 | (set src (random (+ n 1))) 118 | (set dst (random (+ n 1))) 119 | (set k (random (- n (max src dst) -2))) 120 | (set @m (list src dst k)) ) 121 | 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | ;;;; ;;;; 125 | ;;;; ;;;; 126 | ;;;; ;;;; 127 | ;;;; ;;;; 128 | ;;;; ;;;; 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | ;(include "common.tin") 133 | 134 | ;(defstart test-permute) 135 | 136 | (defnet test-permute () 137 | (deflocal n p a i) 138 | 139 | (set n 20) 140 | (set p (perm-identity n)) 141 | 142 | (set a (array 100)) 143 | (for i in 0 .. 99 do 144 | (set (perm-random-move p)) 145 | (set p (perm-move p )) 146 | (print " : " p nl) ) 147 | 148 | (print nl nl) 149 | 150 | (for i in 0 .. 99 rev do 151 | (set p (perm-move p )) 152 | (print " : " p nl) ) 153 | 154 | (skip) 155 | (skip) ) 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | ;;;; ;;;; 160 | ;;;; ;;;; 161 | ;;;; ;;;; 162 | ;;;; ;;;; 163 | ;;;; ;;;; 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 166 | 167 | (defun perm-convert (n) net perm-convert) 168 | (defnet perm-convert (n @m) 169 | (deflocal p) 170 | 171 | (set p <_kv "prm">) 172 | (if (= p undef) 173 | then (set @m n) 174 | else (set @m

) )) 175 | 176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | ;;;; ;;;; 179 | ;;;; ;;;; 180 | ;;;; ;;;; 181 | ;;;; ;;;; 182 | ;;;; ;;;; 183 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | 186 | -------------------------------------------------------------------------------- /project.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet project-open-cb (self) 12 | (opt (project-open-low self)) ) 13 | 14 | (defnet project-open-low (self) 15 | (deflocal a i path) 16 | 17 | (set a (cons (queue) (queue))) 18 | (sqlite3-exec-data _db (netptr project-open-cback) a 19 | "SELECT name,path1,path2 FROM projects ORDER BY name" ) 20 | (if (= (length (car a)) 0) 21 | then (iup-warning60 self $"There are no valid projects.") 22 | (fail) ) 23 | (set i (iup-choose-menu (car a))) 24 | (integerp i) 25 | (set path (car <(cdr a) i>)) 26 | (alt (open-common-low 1 path false) 27 | (sound-iup-error60 self (+ "can't open `" path "'")) ) 28 | (set path (cdr <(cdr a) i>)) 29 | (alt (open-common 2 path) 30 | (sound-iup-error60 self (+ "can't open `" path "'")) ) 31 | (gui-report) 32 | (gui-update-image) 33 | (gui-update) ) 34 | 35 | (defnet project-open-cback (a name path1 path2) 36 | (if (and (pathexists path1) (pathexists path2)) 37 | then (queue-put (car a) name) 38 | (queue-put (cdr a) (cons path1 path2)) )) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | ;;;; ;;;; 43 | ;;;; ;;;; 44 | ;;;; ;;;; 45 | ;;;; ;;;; 46 | ;;;; ;;;; 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | (defnet project-save-cb (self) 51 | (sqlite3-begin _db) 52 | (alt (seq (project-save-low self) 53 | (sqlite3-end _db) 54 | (gui-update) ) 55 | (sqlite3-rollback _db) )) 56 | 57 | (defnet project-save-low (self) 58 | (deflocal path1 path2 name newname) 59 | 60 | (set path1 <_kv "path1">) 61 | (stringp path1) 62 | (set path2 <_kv "path2">) 63 | (stringp path2) 64 | (set path1 (sqlite3-escape-strings path1)) 65 | (set path2 (sqlite3-escape-strings path2)) 66 | (set name <(sqlite3-exec _db 67 | "SELECT name FROM projects WHERE path1='" path1 68 | "' AND path2='" path2 "' LIMIT 1") 0 0> ) 69 | (if (stringp name) 70 | then (set newname name) 71 | (iup-edit-string self $"Rename project" $"Project name" newname) 72 | (stringp newname) 73 | (<> newname "") 74 | (<> newname name) 75 | (alt (sqlite3-exec _db undef 76 | "UPDATE projects SET name='" (sqlite3-escape-strings newname) 77 | "' WHERE name='" (sqlite3-escape-strings name) "'" ) 78 | (seq (iup-confirm60 self (+ $"Project `" newname $"' exists. Do you want to overwrite it?")) 79 | (sqlite3-exec _db undef 80 | "DELETE FROM projects WHERE name='" (sqlite3-escape-strings newname) "'") 81 | (sqlite3-exec _db undef 82 | "UPDATE projects SET name='" (sqlite3-escape-strings newname) 83 | "' WHERE name='" (sqlite3-escape-strings name) "'" )) 84 | (seq (sound-iup-error60 self "Database error") 85 | (fail) )) 86 | else (iup-edit-string self $"Save project" $"Project name" name) 87 | (stringp name) 88 | (<> name "") 89 | (alt (sqlite3-exec _db undef 90 | "INSERT INTO projects VALUES('" (sqlite3-escape-strings name) 91 | "','" path1 92 | "','" path2 93 | "')" ) 94 | (seq (iup-confirm60 self (+ $"Project `" name $"' exists. Do you want to overwrite it?")) 95 | (sqlite3-exec _db undef 96 | "UPDATE projects SET path1='" path1 97 | "',path2='" path2 98 | "' WHERE name='" (sqlite3-escape-strings name) "'" )) 99 | (seq (sound-iup-error60 self "Database error") 100 | (fail) ))) 101 | (iup-info60 self $"Project successfully saved.") ) 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | ;;;; ;;;; 106 | ;;;; ;;;; 107 | ;;;; ;;;; 108 | ;;;; ;;;; 109 | ;;;; ;;;; 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | 113 | (defnet project-delete-cb (self) 114 | (opt (project-delete-low self) 115 | (gui-update) )) 116 | 117 | (defnet project-delete-low (self) 118 | (deflocal av1 av2 path1 path2 name) 119 | 120 | (set av1 <_kv "av1">) 121 | (<> av1 undef) 122 | (set av2 <_kv "av2">) 123 | (<> av2 undef) 124 | (set name <(sqlite3-exec _db 125 | "SELECT name FROM projects WHERE path1='" (sqlite3-escape-strings <_kv "path1">) 126 | "' AND path2='" (sqlite3-escape-strings <_kv "path2">) "' LIMIT 1") 0 0> ) 127 | (stringp name) 128 | (iup-confirm60 self (+ $"Project `" name $"' will be deleted." ' ' $"Are you sure?")) 129 | (sqlite3-exec _db undef 130 | "DELETE FROM projects WHERE name='" (sqlite3-escape-strings name) "'") 131 | (iup-info60 self $"Project successfully deleted.") ) 132 | 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | ;;;; ;;;; 136 | ;;;; ;;;; 137 | ;;;; ;;;; 138 | ;;;; ;;;; 139 | ;;;; ;;;; 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 142 | 143 | (defnet project-export-cb (self) 144 | (opt (project-export-low self)) ) 145 | 146 | (defnet project-export-low (self) 147 | (deflocal av1 av2 path1 path2 name1 name2 path db project-name) 148 | 149 | (set av1 <_kv "av1">) 150 | (<> av1 undef) 151 | (set av2 <_kv "av2">) 152 | (<> av2 undef) 153 | (set path1 <_kv "path1">) 154 | (set path2 <_kv "path2">) 155 | (set name1 (fullpath->name path1)) 156 | (set name2 (fullpath->name path2)) 157 | (set path1 (sqlite3-escape-strings path1)) 158 | (set path2 (sqlite3-escape-strings path2)) 159 | (set project-name <(sqlite3-exec _db 160 | "SELECT name FROM projects WHERE path1='" path1 161 | "' AND path2='" path2 "' LIMIT 1") 0 0> ) 162 | 163 | (set path (cfg-get "save-path")) 164 | (if (not (stringp path)) 165 | then (set path (cfg-get "path")) ) 166 | (set path (iup-choose-file-save self 167 | $"Export project data as..." 168 | path 169 | (+ (if (stringp project-name) project-name "project-data") ".cfg") 170 | true )) 171 | (stringp path) 172 | 173 | (cfg-set "save-path" path) 174 | 175 | (opt (remove path)) 176 | (set db (sqlite3-open path)) 177 | (<> db undef) 178 | 179 | (sqlite3-begin db) 180 | (alt (iup-progress 181 | (thread-create (netptr project-export-th) (thread-self) db av1 av2 path1 path2 name1 name2 project-name) 182 | self "Exporting..." true false false false true ) 183 | (seq (sqlite3-rollback db) 184 | (close db) 185 | (remove path) 186 | (sound-iup-error60 self "Error.") 187 | (fail) )) 188 | (sqlite3-end db) 189 | (close db) 190 | (iup-info60 self $"Project data successfully exported.") ) 191 | 192 | (defnet project-export-th (th db av1 av2 path1 path2 name1 name2 project-name) 193 | (alt (seq (project-export-th-low th db av1 av2 path1 path2 name1 name2 project-name) 194 | (send "q" to th) ) 195 | (send "a" to th) )) 196 | 197 | (defnet project-export-th-low (th db av1 av2 path1 path2 name1 name2 project-name) 198 | (deflocal key) 199 | 200 | (sqlite3-exec db undef 201 | "CREATE TABLE config(" \ 202 | "key char unique not null," \ 203 | "value char not null)" ) 204 | (sqlite3-exec db undef 205 | "CREATE TABLE paths(" \ 206 | "path char unique not null," \ 207 | "name char not null)" ) 208 | (sqlite3-exec db undef 209 | "CREATE TABLE projects(" \ 210 | "name char unique not null," \ 211 | "path1 char not null," \ 212 | "path2 char not null)" ) 213 | 214 | (sqlite3-exec db undef 215 | "INSERT INTO paths VALUES('" 216 | path1 "','" 217 | (sqlite3-escape-strings name1) "')" ) 218 | (sqlite3-exec db undef 219 | "INSERT INTO paths VALUES('" 220 | path2 "','" 221 | (sqlite3-escape-strings name2) "')" ) 222 | 223 | (if (stringp project-name) 224 | then (sqlite3-exec db undef 225 | "INSERT INTO projects VALUES('" (sqlite3-escape-strings project-name) 226 | "','" path1 227 | "','" path2 228 | "')" )) 229 | 230 | (set key (key-scd av1 name1)) 231 | (cfg-set-low db key (cfg-get key)) 232 | (set key (key-scd av2 name2)) 233 | (cfg-set-low db key (cfg-get key)) 234 | (set key (key-sck av1 av2 name1 name2)) 235 | (cfg-set-low db key (cfg-get key)) 236 | (set key (key-map av1 av2 name1 name2)) 237 | (cfg-set-low db key (cfg-get key)) 238 | (set key (key-prm av1 av2 name1 name2)) 239 | (cfg-set-low db key (cfg-get key)) 240 | 241 | (sqlite3-exec db undef 242 | "CREATE INDEX paths_name ON paths(name)" ) 243 | (sqlite3-exec db undef 244 | "CREATE INDEX projects_path1 ON projects(path1)" ) 245 | (sqlite3-exec db undef 246 | "CREATE INDEX projects_path2 ON projects(path2)" )) 247 | 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 250 | ;;;; ;;;; 251 | ;;;; ;;;; 252 | ;;;; ;;;; 253 | ;;;; ;;;; 254 | ;;;; ;;;; 255 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 256 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 257 | 258 | -------------------------------------------------------------------------------- /scdscan.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet scdscan (th-main name av pix default-info which @v) 12 | (deflocal key) 13 | 14 | (pix-wip pix) 15 | (opt (gui-draw-image-th th-main)) 16 | (sendbuf 100 (cons "p2" "scanning ") to th-main) 17 | (sendbuf 100 (cons "p2c" (cons (blue) name)) to th-main) 18 | (sendbuf 100 (cons "p2" "...\n") to th-main) 19 | (set key (key-scd av name)) 20 | (set @v (cfg-get key)) 21 | (if (<> @v undef) 22 | then (set @v <@v 4>) 23 | else (set @v (array default 0 (- (av-approximated-number-of-frames av) 1))) 24 | (if (and (cmingw) (= (csysbits) 32)) 25 | then (scdscan-low-alternate th-main name av pix default-info (my-av-par which av) @v) 26 | else (scdscan-low th-main name av pix default-info (my-av-par which av) @v) ) 27 | (cfg-set key (list (width av) (height av) (av-approximated-number-of-frames av) name @v)) )) 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;;; ;;;; 32 | ;;;; ;;;; 33 | ;;;; ;;;; 34 | ;;;; ;;;; 35 | ;;;; ;;;; 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | (defnet scdscan-low (th-main name av pix default-info par v) 40 | (deflocal path nthreads nframes t d threads th tot msg i) 41 | 42 | (set path (av-path av)) 43 | (set nthreads (cfg-get-or-default-num "scd-threads" default-info)) 44 | (set nframes (+ (length v) 1)) 45 | 46 | (set t (now)) 47 | 48 | (repeat (set d (/ (- (length v) 1) nthreads)) 49 | until (= nthreads 1) 50 | until (>= d 10) 51 | (dec nthreads) ) 52 | (set threads (array nthreads)) 53 | (for i in 1 .. nthreads do 54 | (set (thread-create (netptr scdscan-segment-th) 55 | (thread-self) 56 | path 57 | (floor (* d (for-pos))) 58 | (+ (ceil (* d i)) 1) v ))) 59 | 60 | (sendbuf 100 (cons "p2" "scanning threads: ") to th-main) 61 | (sendbuf 100 (cons "p2c" (cons (blue) (sprint nthreads nl))) to th-main) 62 | 63 | (set tot 0) 64 | 65 | (while (> (length threads) 0) do 66 | (receive msg from th in threads) 67 | (alt (seq (integerp msg) 68 | (set tot (min (+ tot msg) nframes)) 69 | (sendbuf 100 (cons "c1" (+ "frame " tot "/" nframes 70 | " (" (rint (/ tot (- (now) t))) " fps) (" 71 | (rint (/ tot nframes 0.01)) "%)" )) 72 | to th-main )) 73 | (seq (or (= msg "q") (= (car msg) "e")) 74 | (if (= (car msg) "e") 75 | then (if (integerp (cdr msg)) 76 | then (sendbuf 100 (cons "p2" 77 | (+ $"frame # " (cdr msg) $" is not recoverable by a seek" nl) ) 78 | to th-main ) 79 | (sendbuf 100 (cons "p2c" (cons (red) 80 | (+ $"too irregular timestamps not supported\n(more info in the guide)" nl) )) 81 | to th-main )) 82 | (set <_abort 0> true) ) 83 | (in th threads i) 84 | (array-remove threads i) 85 | (thread-join th) ) 86 | (success) )) 87 | 88 | (not <_abort 0>) 89 | (sendbuf 100 (cons "c1" (+ "frame " nframes "/" nframes 90 | " (" (rint (/ tot (- (now) t))) " fps) (100%)")) to th-main )) 91 | 92 | (defnet scdscan-segment-th (th path beg end v) 93 | (deflocal res) 94 | 95 | (set res (array 1)) 96 | (alt (seq (scdscan-segment-low th path beg end v res) 97 | (send "q" to th) ) 98 | (send (cons "e" ) to th) )) 99 | 100 | (defnet scdscan-segment-low (th path beg end v res) 101 | (deflocal av frm hst frameno cnt prv) 102 | 103 | (set av (av-avformat-open-input path)) 104 | (<> av undef) 105 | 106 | (set frm (pix-create (width av) (height av))) 107 | (pixp frm) 108 | 109 | (set hst (array 2)) 110 | (set (raw 256)) 111 | (rawp ) 112 | (set (raw 256)) 113 | (rawp ) 114 | 115 | (set end (min end (- (length v) 1))) 116 | 117 | (set frameno beg) 118 | (set cnt 0) 119 | (set prv 0) 120 | 121 | (alt (seq (av-read-frame av frm frameno) 122 | (= (av-frameno av) frameno) 123 | (truep (av-is-frame-recoverable av)) 124 | (pix-scd-histogram-set frm ) ) 125 | (seq (close av frm ) 126 | (set frameno) 127 | (fail) )) 128 | 129 | (while (not <_abort 0>) do 130 | (inc frameno) 131 | until (> frameno end) 132 | (inc cnt) 133 | (alt (seq (av-read-frame av frm frameno) 134 | (= (av-frameno av) frameno) 135 | (truep (av-is-frame-recoverable av)) 136 | (pix-scd-histogram-set frm ) 137 | (set (pix-scd-histogram-dist )) 138 | (if (= (% cnt 100) 0) 139 | then (sendbuf 30 (- cnt prv) to th) 140 | (set prv cnt) )) 141 | (seq ; hack che rende tollerabile l'illeggibilità 142 | ; di (pochi) ultimi frame 143 | (< (- (length v) frameno) 150) 144 | (set frameno end) ) 145 | (seq (close av frm ) 146 | (set frameno) 147 | (fail) ))) 148 | (close av frm ) 149 | (not <_abort 0>) 150 | (if (> cnt prv) 151 | then (send (- cnt prv) to th) )) 152 | 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | ;;;; ;;;; 156 | ;;;; ;;;; 157 | ;;;; ;;;; 158 | ;;;; ;;;; 159 | ;;;; ;;;; 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 162 | 163 | (defnet scdscan-low-alternate (th-main name av pix default-info par v) 164 | (deflocal done abort l l1 hst idx frameno t) 165 | 166 | (av-rewind av) 167 | 168 | (set l1 (length v)) 169 | (set l (+ l1 1)) 170 | 171 | (set hst (array 2)) 172 | (set (raw 256)) 173 | (set (raw 256)) 174 | 175 | (set t (now)) 176 | 177 | (av-read-scd-histogram-set av ) 178 | (set idx 1) 179 | (set done false) 180 | (set abort false) 181 | (repeat (alt (av-read-scd-histogram-set av ) 182 | (set done true) ) 183 | until done 184 | (set frameno (av-frameno av)) 185 | until (>= frameno l1) 186 | (if (not (av-is-frame-recoverable av)) 187 | then (sendbuf 100 (cons "p2" (+ $"frame # " frameno $" is not recoverable by a seek" nl 188 | $"expected timestamp" ": " (approx4 (av-frameno2ts av frameno)) " s" nl 189 | $"detected timestamp" ": " (approx4 (* (av-ts av) (av-time-base av (av-video-stream-idx av)))) " s" 190 | nl )) to th-main ) 191 | (sendbuf 100 (cons "p2c" (cons (red) (+ $"too irregular timestamps not supported\n(more info in the guide)" nl ))) to th-main) 192 | (set abort true) ) 193 | (if <_abort 0> 194 | then (set abort true) ) 195 | until abort 196 | (set (pix-scd-histogram-dist )) 197 | (if (= (% frameno 100) 0) 198 | then (sendbuf 100 (cons "c1" (+ "frame " frameno "/" l " (" (rint (/ frameno (- (now) t))) 199 | " fps) (" (rint (/ frameno l 0.01)) "%)" )) 200 | to th-main )) 201 | (set idx (- 1 idx)) ) 202 | 203 | (close ) 204 | (not abort) 205 | (sendbuf 100 (cons "c1" (+ "frame " l "/" l " (" (rint (/ frameno (- (now) t))) " fps) (100%)")) to th-main) ) 206 | 207 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 208 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 | ;;;; ;;;; 210 | ;;;; ;;;; 211 | ;;;; ;;;; 212 | ;;;; ;;;; 213 | ;;;; ;;;; 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 216 | 217 | -------------------------------------------------------------------------------- /sift.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet sift-check (alternate m p1 p2 @score) 12 | (deflocal cache key) 13 | 14 | (opt (match-receivenb m)) 15 | (not (match-abort m)) 16 | (set cache (match-cache m)) 17 | (set key (+ (int->str p1 6 '0') (int->str p2 6 '0'))) 18 | (set @score ) 19 | (if (= @score undef) 20 | then (sift-check-basic alternate m p1 p2 cache key @score) ) 21 | (if (booleanp @score) 22 | then (= @score true) 23 | (set @score 0) )) 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;;;; ;;;; 28 | ;;;; ;;;; 29 | ;;;; ;;;; 30 | ;;;; ;;;; 31 | ;;;; ;;;; 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | 35 | (defnet sift-check-basic (alternate m p1 p2 cache key @score) 36 | (deflocal av1 av2 frm1 frm2 dlum filt1 filt2 k1 k2) 37 | 38 | (msg-log m (+ "sift check: " p1 " <-> " p2 nl)) 39 | (set av1 (match-av1 m)) 40 | (set av2 (match-av2 m)) 41 | (set frm1 (match-frm1 m)) 42 | (set frm2 (match-frm2 m)) 43 | (sift-read-frame m av1 p1 frm1) 44 | (sift-read-frame m av2 (perm-convert p2) frm2) 45 | (if (match-params m "filter-mirror1") 46 | then (pix-hflip frm1) ) 47 | (if (match-params m "filter-flip1") 48 | then (pix-vflip frm1) ) 49 | (if (match-params m "filter-mirror2") 50 | then (pix-hflip frm2) ) 51 | (if (match-params m "filter-flip2") 52 | then (pix-vflip frm2) ) 53 | (send frm1 to (match-th-sift1 m)) 54 | (send frm2 to (match-th-sift2 m)) 55 | (set dlum (/ (- (pix-get-luminance frm1) (pix-get-luminance frm2)) 255)) 56 | (pix-copy-frames (match-pix m) frm1 frm2 (match-pix1 m) (match-pix2 m) 57 | (match-params m "filter-gamma1") (match-params m "filter-gamma2") ) 58 | (sift-draw-image m) 59 | (receive filt1 from (match-th-sift1 m)) 60 | (receive filt2 from (match-th-sift2 m)) 61 | (alt (seq (not (match-abort m)) 62 | (set k1 (if (= filt1 undef) 0 (length filt1))) 63 | (set k2 (if (= filt2 undef) 0 (length filt2))) 64 | (if (< (min k1 k2) (match-params m "min-keypoints")) 65 | then (if alternate 66 | then (sift-check-too-few-keypoints m p1 p2 filt1 filt2 k1 k2 dlum @score) 67 | else (set @score true) ) 68 | else (sift-check-enough-keypoints m filt1 filt2 k1 k2 dlum @score) ) 69 | (set @score) 70 | (if (booleanp @score) 71 | then (if @score 72 | then (inc ) 73 | else (if (match-params m "sift-draw-lines") 74 | then (sift-draw-x m) 75 | (sift-draw-image m) ))) 76 | (not (match-abort m)) 77 | (close filt1 filt2) ) 78 | (seq (close filt1 filt2) 79 | (fail) ))) 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | ;;;; ;;;; 84 | ;;;; ;;;; 85 | ;;;; ;;;; 86 | ;;;; ;;;; 87 | ;;;; ;;;; 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | (defnet sift-check-too-few-keypoints (m p1 p2 filt1 filt2 k1 k2 dlum @score) 92 | (if (< (max k1 k2) (match-params m "min-keypoints")) 93 | then (set @score true) 94 | else (if (< 40) 95 | then (msg-log m (+ "delayed (dlum=" (approx3 dlum) ")" nl)) 96 | (fail) ) 97 | (if (> (abs (- dlum (/ ))) (match-params m "min-keypoints-min-ratio-lum")) 98 | then (set @score false) 99 | else (set @score (>= (/ (min k1 k2) (max k1 k2)) (match-params m "min-keypoints-min-ratio"))) )) 100 | (msg-log m (+ "too few keypoints (" k1 "," k2 ": " @score ") - dlum: " 101 | (approx3 dlum) " (avg: " (approx3 (/ )) ")" nl ))) 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | ;;;; ;;;; 106 | ;;;; ;;;; 107 | ;;;; ;;;; 108 | ;;;; ;;;; 109 | ;;;; ;;;; 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | 113 | (defnet sift-check-enough-keypoints (m filt1 filt2 k1 k2 dlum @score) 114 | (deflocal matches nx ny bnx bny sumrx sumry deltax deltay avgx avgy rx ry) 115 | 116 | (set matches (sift-match filt1 filt2 (match-params m "sift-match-threshold-val"))) 117 | (if (< (/ (length matches) (min k1 k2)) (match-params m "sift-match-threshold-min-ratio")) 118 | then (set @score false) 119 | (msg-log m (+ "too few matches (" (length matches) " [" k1 "," k2 "])" nl)) 120 | else (sift-analyze matches nx ny bnx bny sumrx sumry deltax deltay) 121 | (if (= (min nx ny) 0) 122 | then (set @score false) 123 | (msg-log m (+ "too few agreements (" nx "," ny ")" nl)) 124 | else (if (and (= (min ) 0) 125 | (< (min bnx bny) (match-params m "sift-agreements-min")) ) 126 | then (msg-log m (+ "delayed (" bnx "," bny ")" nl)) 127 | (fail) ) 128 | (set sumrx (* sumrx (match-hcorrection m))) 129 | (set sumry (* sumry (match-vcorrection m))) 130 | (set avgx (/ sumrx bnx)) 131 | (set avgy (/ sumry bny)) 132 | (msg-log m (+ "x -> " bnx " (" (approx2 (/ bnx nx 0.01)) "%): " (approx3 avgx) nl 133 | "y -> " bny " (" (approx2 (/ bny ny 0.01)) "%): " (approx3 avgy) nl )) 134 | (set rx (if (= 0) avgx (match-rx m))) 135 | (set ry (if (= 0) avgy (match-ry m))) 136 | (if (or (< (/ (min avgx rx) (max avgx rx)) 137 | (match-params m "sift-proportionality-threshold") ) 138 | (< (/ (min avgy ry) (max avgy ry)) 139 | (match-params m "sift-proportionality-threshold") )) 140 | then (set @score false) 141 | (msg-log m (+ "proportionality check failed" nl)) 142 | else (if (match-params m "sift-draw-lines") 143 | then (sift-draw-matches m matches) 144 | (sift-draw-image m) ) 145 | (set @score (+ (/ bnx nx) (/ bny ny))) 146 | (inc ) 147 | (inc ) 148 | (inc (approximate dlum)) 149 | (if (>= (min bnx bny) (match-params m "sift-agreements-min")) 150 | then (inc bnx) 151 | (set (approximate (+ sumrx))) 152 | (inc bny) 153 | (set (approximate (+ sumry))) ))))) 154 | 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | ;;;; ;;;; 158 | ;;;; ;;;; 159 | ;;;; ;;;; 160 | ;;;; ;;;; 161 | ;;;; ;;;; 162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 | 165 | (defnet sift-read-frame (m av p frm) 166 | (alt (av-read-frame av frm p) 167 | (seq (pix-clear frm) 168 | (msg-log m (+ "\n\n\nwarning: can't read frame " p nl nl nl)) ))) 169 | 170 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | ;;;; ;;;; 173 | ;;;; ;;;; 174 | ;;;; ;;;; 175 | ;;;; ;;;; 176 | ;;;; ;;;; 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | 180 | (defnet sift-analyze (matches @nx @ny @bnx @bny @sumrx @sumry @deltax @deltay) 181 | (deflocal l) 182 | 183 | (set l (sift-analyze matches)) 184 | (list-pop l @nx) 185 | (list-pop l @ny) 186 | (list-pop l @bnx) 187 | (list-pop l @bny) 188 | (list-pop l @sumrx) 189 | (list-pop l @sumry) 190 | (list-pop l @deltax) 191 | (list-pop l @deltay) ) 192 | 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 195 | ;;;; ;;;; 196 | ;;;; ;;;; 197 | ;;;; ;;;; 198 | ;;;; ;;;; 199 | ;;;; ;;;; 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | 203 | (defnet sift-draw-matches (m matches) 204 | (deflocal color pix kx1 ky1 kx2 ky2 sx1 sy1 sx2 sy2 cr raw i cnt) 205 | 206 | (set color (purple)) 207 | (set pix (match-pix m)) 208 | (set kx1 (/ (width (match-pix1 m)) (width (match-frm1 m)))) 209 | (set ky1 (/ (height (match-pix1 m)) (height (match-frm1 m)))) 210 | (set kx2 (/ (width (match-pix2 m)) (width (match-frm2 m)))) 211 | (set ky2 (/ (height (match-pix2 m)) (height (match-frm2 m)))) 212 | (set sx1 (/ (- (width pix) (width (match-pix1 m))) 2)) 213 | (set sy1 (/ (- (height pix) (height (match-pix1 m)) (height (match-pix2 m)) (space)) 2)) 214 | (set sx2 (/ (- (width pix) (width (match-pix2 m))) 2)) 215 | (set sy2 (+ sy1 (height (match-pix1 m)) (space))) 216 | ; (set cr (cairo-svg-surface-create-for-stream (width pix) (height pix))) 217 | ; (cairo-set-source-rgba cr color) 218 | ; (cairo-set-line-width cr 1) 219 | (set cnt 0) 220 | (while (and (> (length matches) 0) (< cnt 2000)) do 221 | (inc cnt) 222 | (set i (queue-get matches)) 223 | ; (cairo-move-to cr (+ (* (car (car i)) kx1) sx1) (+ (* (cdr (car i)) ky1) sy1)) 224 | ; (cairo-line-to cr (+ (* (car (cdr i)) kx2) sx2) (+ (* (cdr (cdr i)) ky2) sy2)) 225 | (pix-draw-line pix (+ (* (car (car i)) kx1) sx1) (+ (* (cdr (car i)) ky1) sy1) 226 | (+ (* (car (cdr i)) kx2) sx2) (+ (* (cdr (cdr i)) ky2) sy2) 227 | color ) 228 | (skip) ) 229 | ; (pix-draw-and-close-cairo pix cr) 230 | (skip) ) 231 | 232 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 233 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 234 | ;;;; ;;;; 235 | ;;;; ;;;; 236 | ;;;; ;;;; 237 | ;;;; ;;;; 238 | ;;;; ;;;; 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | 242 | (defnet sift-draw-x (m) 243 | (deflocal pix cr raw w1 h1 w2 h2) 244 | 245 | (set pix (match-pix m)) 246 | (set cr (cairo-svg-surface-create-for-stream (width pix) (height pix))) 247 | (cairo-scale cr 1 1) 248 | (cairo-set-source-rgba cr (red)) 249 | (set w1 (width (match-pix1 m))) 250 | (set h1 (height (match-pix1 m))) 251 | (set w2 (width (match-pix2 m))) 252 | (set h2 (height (match-pix2 m))) 253 | (cairo-move-to cr (/ (- (width pix) w1) 2) (/ (- (height pix) h1 h2 (space)) 2)) 254 | (cairo-line-to cr (+ (/ (- (width pix) w2) 2) w2 -1) (+ (/ (- (height pix) h1 h2 (space)) 2) h1 (space) h2 -1)) 255 | (cairo-move-to cr (+ (/ (- (width pix) w1) 2) w1 -1) (/ (- (height pix) h1 h2 (space)) 2)) 256 | (cairo-line-to cr (/ (- (width pix) w2) 2) (+ (/ (- (height pix) h1 h2 (space)) 2) h1 (space) h2 -1)) 257 | (cairo-set-line-width cr 10) 258 | (cairo-stroke cr) 259 | (set raw (cairo-flush-and-close-raw cr)) 260 | (rawp raw) 261 | (set cr (rsvg-load raw)) 262 | (close raw) 263 | (pix-draw-pix-alpha pix 0 0 cr) 264 | (close cr) ) 265 | 266 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | ;;;; ;;;; 269 | ;;;; ;;;; 270 | ;;;; ;;;; 271 | ;;;; ;;;; 272 | ;;;; ;;;; 273 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | 276 | (defnet sift-draw-image (m) 277 | (deflocal th-main msg) 278 | 279 | (set th-main (match-th-main m)) 280 | (send [ "d" . undef ] to th-main) 281 | (receive msg from th-main) 282 | (if (not msg) 283 | then (receive msg from th-main) 284 | (match-abort m) )) 285 | 286 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 287 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 288 | ;;;; ;;;; 289 | ;;;; ;;;; 290 | ;;;; ;;;; 291 | ;;;; ;;;; 292 | ;;;; ;;;; 293 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | 296 | -------------------------------------------------------------------------------- /sound.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet sound-play (snd) 12 | (send snd to <_kv "th-sound">) ) 13 | 14 | (defnet sound-alert () 15 | (sound-play (raw-load-static "alert.wav")) ) 16 | 17 | (defnet sound-pop () 18 | (sound-play (raw-load-static "pop.wav")) ) 19 | 20 | (defnet sound-info () 21 | (sound-play (raw-load-static "info.wav")) ) 22 | 23 | (defnet sound-error () 24 | (sound-play (raw-load-static "error.wav")) ) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;;;; ;;;; 29 | ;;;; ;;;; 30 | ;;;; ;;;; 31 | ;;;; ;;;; 32 | ;;;; ;;;; 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (defnet sound-iup-info60 (self msg) 37 | (sound-info) 38 | (iup-info60 self msg) ) 39 | 40 | (defnet sound-iup-error60 (self msg) 41 | (sound-error) 42 | (iup-error60 self msg) ) 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | ;;;; ;;;; 47 | ;;;; ;;;; 48 | ;;;; ;;;; 49 | ;;;; ;;;; 50 | ;;;; ;;;; 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | -------------------------------------------------------------------------------- /threads.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defnet th-clock (th) 12 | (deflocal delay) 13 | 14 | (repeat (receive delay from th) 15 | until (= delay undef) 16 | (sleep delay) 17 | (send true to th) )) 18 | 19 | (defnet th-clock-send (delay) 20 | (deflocal thclk done res) 21 | 22 | (set thclk <_kv "th-clock">) 23 | (set done false) 24 | (repeat (alt (seq (sendnb delay to thclk) 25 | (set done true) ) 26 | (seq (receivenb res from thclk) 27 | (send delay to thclk) 28 | (set done true) ) 29 | (success) ) 30 | until done 31 | (sleep 0.01) )) 32 | 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;;;; ;;;; 36 | ;;;; ;;;; 37 | ;;;; ;;;; 38 | ;;;; ;;;; 39 | ;;;; ;;;; 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | 43 | (defnet th-read-frame (th) 44 | (deflocal req) 45 | 46 | (repeat (receive req from th) 47 | until (= req undef) 48 | (alt (seq (if (= (length req) 2) 49 | then (av-read-frame ) 50 | else (av-read-frame ) ) 51 | (set req true) ) 52 | (set req false) ) 53 | (send req to th) )) 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;;;; ;;;; 58 | ;;;; ;;;; 59 | ;;;; ;;;; 60 | ;;;; ;;;; 61 | ;;;; ;;;; 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | 65 | (defnet th-sift-features (th frm) 66 | (repeat (receive frm from th) 67 | until (not (pixp frm)) 68 | (send (sift-features frm) to th) )) 69 | 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | ;;;; ;;;; 73 | ;;;; ;;;; 74 | ;;;; ;;;; 75 | ;;;; ;;;; 76 | ;;;; ;;;; 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | 80 | (defnet th-sound (th) 81 | (deflocal snd t prev-t) 82 | 83 | (set prev-t (- (now) (* 60 60 24))) 84 | (repeat (receive snd from th) 85 | until (= snd undef) 86 | (set t (now)) 87 | (opt (truep <_kv "sound-enabled">) 88 | ;(if (> (- t prev-t) 30) 89 | ;then (sdl-playwav-memory (raw-load-static "silence.wav") 1.0) ) 90 | (sdl-playwav-memory snd 1.0) ) 91 | (set prev-t t) )) 92 | 93 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | ;;;; ;;;; 96 | ;;;; ;;;; 97 | ;;;; ;;;; 98 | ;;;; ;;;; 99 | ;;;; ;;;; 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | 103 | -------------------------------------------------------------------------------- /utils.tin: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;;; ;;;; 4 | ;;;; ;;;; 5 | ;;;; ;;;; 6 | ;;;; ;;;; 7 | ;;;; ;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defun url-home-page () "http://fsinapsi.altervista.org") 12 | 13 | (defun compile-time () (date (date-year (cdate)) (date-month (cdate)) (date-day (cdate)))) 14 | 15 | (defun date->version (date) 16 | (+ (int->str (date-day date) 2 '0') "-" 17 | (int->str (date-month date) 2 '0') "-" 18 | (int->str (date-year date) 4 '0') )) 19 | 20 | (defun remote-version-key () "ffmatch-win64-20") 21 | 22 | (defun remote-version () net remote-version) 23 | (defnet remote-version (@s) 24 | (deflocal i) 25 | 26 | (set @s (download-as-string (+ (url-home-page) "/code/ffmatch/index.html"))) 27 | (stringp @s) 28 | (search (remote-version-key) @s i) 29 | (set @s (str->date (sub (+ i (- (length (remote-version-key)) 2)) 8 @s))) 30 | (datep @s) ) 31 | 32 | (defun remote-version-cached () net remote-version-cached) 33 | (defnet remote-version-cached (@s) 34 | (deflocal now s) 35 | 36 | (set now (now)) 37 | (set @s (cfg-get "last-check-for-updates-version")) 38 | (set s (- now (cfg-get "last-check-for-updates"))) 39 | (if (or (= @s undef) (= s undef) (> s (* 60 30))) 40 | then (set @s (remote-version)) 41 | (if (= @s undef) 42 | then (set @s (compile-time)) ) 43 | (cfg-set "last-check-for-updates-version" @s) 44 | (cfg-set "last-check-for-updates" now) )) 45 | 46 | (defun gc-version () (gc-version0 (gc-version-major) (gc-version-minor))) 47 | (defun gc-version0 (maj min) 48 | (if (or (= maj undef) (= min undef)) 49 | "< 7.1" 50 | (sprint maj '.' min) )) 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;;;; ;;;; 55 | ;;;; ;;;; 56 | ;;;; ;;;; 57 | ;;;; ;;;; 58 | ;;;; ;;;; 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | (defun key-scd (av name) 63 | (+ "scd-" (key-basic av name)) ) 64 | 65 | (defun key-sck (av1 av2 name1 name2) 66 | (+ "sck-" (key-basic av1 name1) (key-basic av2 name2)) ) 67 | 68 | (defun key-map (av1 av2 name1 name2) 69 | (+ "map-" (key-basic av1 name1) (key-basic av2 name2)) ) 70 | 71 | (defun key-prm (av1 av2 name1 name2) 72 | (+ "prm-" (key-basic av1 name1) (key-basic av2 name2)) ) 73 | 74 | (defun key-basic (av name) 75 | (gcry-sha1sum-fast (+ (if (rmatch (av-codec-name av (av-video-stream-idx av)) "_cuvid") "cuvid" "") 76 | (int->str (width av) 5 '0') 77 | (int->str (height av) 5 '0') 78 | (int->str (av-approximated-number-of-frames av) 6 '0') 79 | name ))) 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | ;;;; ;;;; 84 | ;;;; ;;;; 85 | ;;;; ;;;; 86 | ;;;; ;;;; 87 | ;;;; ;;;; 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | (defun dump-ar-circa (ar val valp) 92 | (if (and (<> ar val) 93 | (< (/ (abs (- ar val)) val) 0.012) ) 94 | (+ " (~" valp ")") 95 | "" )) 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 99 | ;;;; ;;;; 100 | ;;;; ;;;; 101 | ;;;; ;;;; 102 | ;;;; ;;;; 103 | ;;;; ;;;; 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | 107 | (defun array-avg (a) net array-avg) 108 | (defnet array-avg (a @m) 109 | (deflocal l i) 110 | 111 | (set l (length a)) 112 | (set @m 0) 113 | (for i in 1 .. (length a) do 114 | (set @m (approximate (+ @m ))) ) 115 | (if (> l 0) 116 | then (set @m (/ @m l)) )) 117 | 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | ;;;; ;;;; 121 | ;;;; ;;;; 122 | ;;;; ;;;; 123 | ;;;; ;;;; 124 | ;;;; ;;;; 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | 128 | (defun seq-threshold (v min max thr) net seq-threshold) 129 | (defnet seq-threshold (v min max thr @a) 130 | (deflocal i n k) 131 | 132 | (set n 1) 133 | (for i in (+ min 1) .. max do 134 | (if (>= thr) 135 | then (inc n) )) 136 | (set @a (array n)) 137 | (set n 0) 138 | (set k min) 139 | (for i in (+ min 1) .. max do 140 | (if (>= thr) 141 | then (set <@a n> (cons (- i k) k)) 142 | (set k i) 143 | (inc n) )) 144 | (set <@a n> (cons (- max k -1) k)) ) 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 | ;;;; ;;;; 149 | ;;;; ;;;; 150 | ;;;; ;;;; 151 | ;;;; ;;;; 152 | ;;;; ;;;; 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | 156 | (defun my-av-par (which av) net my-av-par) 157 | (defnet my-av-par (which av @par) 158 | (deflocal default-info) 159 | 160 | (set default-info <_kv "default">) 161 | (if (cfg-get-or-default (+ "filter-ar" which "-auto") default-info) 162 | then (set @par (av-sample-aspect-ratio av (av-video-stream-idx av))) 163 | (if (= @par 0) 164 | then (set @par 1) ) 165 | else (set @par (/ (cfg-get-or-default-num (+ "filter-ar" which) default-info) 166 | (/ (width av) (height av)) )))) 167 | 168 | (defun my-av-dar (which av) 169 | (* (/ (width av) (height av)) (my-av-par which av)) ) 170 | 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | ;;;; ;;;; 174 | ;;;; ;;;; 175 | ;;;; ;;;; 176 | ;;;; ;;;; 177 | ;;;; ;;;; 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 180 | 181 | (defnet pix-clear (pix) 182 | (pix-draw-box pix 0 0 (maxint) (maxint) (pix-color 0 0 0 0)) ) 183 | 184 | (defnet pix-clear-and-copy-pix (pix icon) 185 | (pix-clear pix) 186 | (pix-draw-pix pix 187 | (/ (- (width pix) (width icon)) 2) 188 | (/ (- (height pix) (height icon)) 2) 189 | icon )) 190 | 191 | (defnet pix-logo (pix) 192 | (pix-clear-and-copy-pix pix 193 | ;(pix-load-static "128x128/emblem-videos.png") 194 | (pix-load-static "logo.png") 195 | )) 196 | 197 | (defnet pix-wip (pix) 198 | (pix-clear-and-copy-pix pix 199 | (pix-load-static "80x80/work-in-progress.png") )) 200 | 201 | (defnet pix-error (pix) 202 | (pix-clear-and-copy-pix pix 203 | (pix-load-static "48x48/dialog-error-4.png") )) 204 | 205 | (defnet pix-copy-frames (pix frm1 frm2 pix1 pix2 gamma1 gamma2) 206 | (deflocal sy) 207 | 208 | (pix-clear pix) 209 | (pix-sws-scale-bicubic frm1 pix1) 210 | (pix-sws-scale-bicubic frm2 pix2) 211 | (pix-gamma pix1 gamma1) 212 | (pix-gamma pix2 gamma2) 213 | (set sy (/ (- (height pix) (height pix1) (height pix2) (space)) 2)) 214 | (pix-draw-pix pix (/ (- (width pix) (width pix1)) 2) sy pix1) 215 | (pix-draw-pix pix (/ (- (width pix) (width pix2)) 2) (+ sy (height pix1) (space)) pix2) ) 216 | 217 | (defnet pix-create-pixfrm (pix av1 av2 @pix1 @pix2) 218 | (deflocal default-info w1 h1 w2 h2 ww1 hh1 ww2 hh2 k si co) 219 | 220 | (set default-info <_kv "default">) 221 | (set w1 (width av1)) 222 | (set h1 (height av1)) 223 | (set w2 (width av2)) 224 | (set h2 (height av2)) 225 | (set k (my-av-par 1 av1)) 226 | (if (> k 1) 227 | then (set w1 (* w1 k)) 228 | else (set h1 (/ h1 k)) ) 229 | (set k (my-av-par 2 av2)) 230 | (if (> k 1) 231 | then (set w2 (* w2 k)) 232 | else (set h2 (/ h2 k)) ) 233 | (case (cfg-get-or-default-num "scaling-mode" default-info) of 234 | 0 (seq (set k (/ w2 h2)) 235 | (set h2 (sqrt (/ (* w1 h1) k))) 236 | (set w2 (* h2 k)) ) 237 | 1 (seq (set h2 (* h2 (/ w1 w2))) 238 | (set w2 w1) )) 239 | (set k (cfg-get-or-default-num "filter-rotate1" default-info)) 240 | (if (= k 0) 241 | then (set ww1 w1) 242 | (set hh1 h1) 243 | else (if (< k 0) 244 | then (inc k 360) ) 245 | (if (or (= k 90) (= k 270)) 246 | then (set ww1 h1) 247 | (set hh1 w1) 248 | else (if (= k 180) 249 | then (set ww1 w1) 250 | (set hh1 h1) 251 | else (set k (* (/ k 180) (* (atan 1) 4))) 252 | (set si (abs (sin k))) 253 | (set co (abs (cos k))) 254 | (set ww1 (+ (* w1 co) (* h1 si))) 255 | (set hh1 (+ (* h1 co) (* w1 si))) ))) 256 | (set k (cfg-get-or-default-num "filter-rotate2" default-info)) 257 | (if (= k 0) 258 | then (set ww2 w2) 259 | (set hh2 h2) 260 | else (if (< k 0) 261 | then (inc k 360) ) 262 | (if (or (= k 90) (= k 270)) 263 | then (set ww2 h2) 264 | (set hh2 w2) 265 | else (if (= k 180) 266 | then (set ww2 w2) 267 | (set hh2 h2) 268 | else (set k (* (/ k 180) (* (atan 1) 4))) 269 | (set si (abs (sin k))) 270 | (set co (abs (cos k))) 271 | (set ww2 (+ (* w2 co) (* h2 si))) 272 | (set hh2 (+ (* h2 co) (* w2 si))) ))) 273 | (set k (min (/ (- (width pix) (* 2 (space))) (max ww1 ww2)) 274 | (/ (- (height pix) (* 3 (space))) (+ hh1 hh2)) )) 275 | (set @pix1 (pix-create (max 1 (* k w1)) (max 1 (* k h1)))) 276 | (set @pix2 (pix-create (max 1 (* k w2)) (max 1 (* k h2)))) ) 277 | 278 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 279 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 280 | ;;;; ;;;; 281 | ;;;; ;;;; 282 | ;;;; ;;;; 283 | ;;;; ;;;; 284 | ;;;; ;;;; 285 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 286 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 287 | 288 | (defnet msg-log (m msg) 289 | (sendbuf 100 (cons "p2" msg) to (match-th-main m)) ) 290 | 291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 292 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 | ;;;; ;;;; 294 | ;;;; ;;;; 295 | ;;;; ;;;; 296 | ;;;; ;;;; 297 | ;;;; ;;;; 298 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 299 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 300 | 301 | (defnet debug-print (msg) 302 | (deflocal f) 303 | 304 | (if <_kv "debug-enabled"> 305 | then (set f <_kv "debug-fp">) 306 | (if (= f undef) 307 | then (set f (fopenrw <_kv "debug-path">)) 308 | (if (<> f undef) 309 | then (fsetpos (length f) f) 310 | else (set f (fcreate <_kv "debug-path">)) ) 311 | (if (<> f undef) 312 | then (set <_kv "debug-fp"> f) 313 | (da-chiudere f) )) 314 | (if (<> f undef) 315 | then (fprint f (sprint (now) " - " (thread-self) ": " msg nl)) 316 | (fflush f) ))) 317 | 318 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 319 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 320 | ;;;; ;;;; 321 | ;;;; ;;;; 322 | ;;;; ;;;; 323 | ;;;; ;;;; 324 | ;;;; ;;;; 325 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 326 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 327 | 328 | (defnet da-chiudere (obj) 329 | (queue-put <_kv "da-chiudere"> obj) ) 330 | 331 | (defnet quit () 332 | (deflocal thclk th1 th2 thsnd obj) 333 | 334 | (set thclk <_kv "th-clock">) 335 | (th-clock-send undef) 336 | (set th1 <_kv "th-read-frame1">) 337 | (send undef to th1) 338 | (set th2 <_kv "th-read-frame2">) 339 | (send undef to th2) 340 | (set thsnd <_kv "th-sound">) 341 | (send undef to thsnd) 342 | (thread-join thclk) 343 | (thread-join th1) 344 | (thread-join th2) 345 | (thread-join thsnd) 346 | (for obj in <_kv "da-chiudere"> do 347 | (close obj) )) 348 | 349 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 350 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 351 | ;;;; ;;;; 352 | ;;;; ;;;; 353 | ;;;; ;;;; 354 | ;;;; ;;;; 355 | ;;;; ;;;; 356 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358 | 359 | (defnet a () 360 | (deflocal p i j c r g b) 361 | 362 | (set p (pix-load-static "logo.png")) 363 | (for i in 0 .. (- (width p) 1) do 364 | (for j in 0 .. (- (height p) 1) do 365 | (set c (pix-point p i j)) 366 | (set r (pix-color-red c)) 367 | (set g (pix-color-green c)) 368 | (set b (pix-color-blue c)) 369 | (= r g) 370 | (= r b) 371 | (pix-draw-point p i j (pix-color r r r (- 255 r))) )) 372 | (pix-save-png p "pippo.png") ) 373 | 374 | (defnet b () 375 | (deflocal p q z i j c r g b) 376 | 377 | (set p (pix-load-static "logo.png")) 378 | (set q (pix-load-static "128x128/emblem-videos.png")) 379 | 380 | (pix-draw-pix-alpha p (/ (- (width p) (width q)) 2) (/ (- (height p) (height q)) 2) q) 381 | 382 | (set z (pix-load "icons/logo.png")) 383 | 384 | (for i in 0 .. (- (width z) 1) do 385 | (for j in 0 .. (- (height z) 1) do 386 | (set c (pix-point z i j)) 387 | (set r (pix-color-red c)) 388 | (set g (pix-color-green c)) 389 | (set b (pix-color-blue c)) 390 | (pix-draw-point z i j (pix-color r g 0xff (pix-color-alpha c))) )) 391 | 392 | (pix-draw-pix-alpha p 0 0 z) 393 | 394 | (pix-save-png p "pippo.png") ) 395 | 396 | (defnet c () 397 | (deflocal p q z i j c r g b) 398 | 399 | (set p (pix-load "icons/sfondo2.png")) 400 | (set q (pix-load "icons/logo-alt4.png")) 401 | (for i in 0 .. (- (width p) 1) do 402 | (for j in 0 .. (- (height p) 1) do 403 | (set c (pix-point p i j)) 404 | (pix-draw-point p i j (pix-color 405 | (pix-color-red c) 406 | (pix-color-green c) 407 | (pix-color-blue c) 408 | (pix-color-alpha (pix-point q i j)) )))) 409 | 410 | (set z (pix-clone p)) 411 | 412 | (close q) 413 | 414 | (set q (pix-load-static "128x128/emblem-videos.png")) 415 | 416 | (pix-draw-pix-alpha p (/ (- (width p) (width q)) 2) (/ (- (height p) (height q)) 2) q) 417 | 418 | (pix-draw-pix-alpha p 0 0 z) 419 | 420 | (pix-save-png p "pippo.png") ) 421 | 422 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 423 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 424 | ;;;; ;;;; 425 | ;;;; ;;;; 426 | ;;;; ;;;; 427 | ;;;; ;;;; 428 | ;;;; ;;;; 429 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 430 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 431 | 432 | --------------------------------------------------------------------------------