forked from FrancoisMalan/DivideScannedImages
-
Notifications
You must be signed in to change notification settings - Fork 0
/
DivideScannedImages.scm
501 lines (466 loc) · 21.8 KB
/
DivideScannedImages.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
; Isolage Images On Background
; iiob.scm
; by nobisoft, Jan 2020
; Based on all the work of the other nice people mentioned below! See https://github.com/FrancoisMalan/DivideScannedImages
; Added two options to batch processing:
; - Recurse into subdirectories
; - Use original file name for cropped images (instead of constant filename prefix) (and start numbering at 1 for each original in this case)
; DivideScannedImages.scm
; by Francois Malan
; Based on a script originally by Rob Antonishen http://ffaat.pointclark.net
;
; Locates each separate element in an image and creates a new image from each.
; if option is selected, will call the deskew plugin by Karl Chen https://github.com/prokoudine/gimp-deskew-plugin (if it is installed) on each item
;
; License:
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU General Public License for more details.
;
; The GNU Public License is available at
; http://www.gnu.org/copyleft/gpl.html
(define (script-fu-isolate-images-on-background img inLayer inSquareCrop inPadding inLimit inDeskew inAutoClose inThreshold inSize inDefBg inBgCol inCorner inX inY inSaveInSourceDir inDir inSaveType inJpgQual inFileName inFileNumber)
(let*
(
(inSaveFiles TRUE)
(width (car (gimp-image-width img)))
(height (car (gimp-image-height img)))
(newpath 0)
(strokes 0)
(tempVector 0)
(tempImage 0)
(tempLayer 0)
(bounds 0)
(centroidx 0)
(centroidy 0)
(sizex 0)
(sizey 0)
(halfsidelength 0)
(sidelength 0)
(count 0)
(numextracted 0)
(saveString "")
(newFileName "")
(tempdisplay 0)
(buffname "dsibuff")
(pathchar (if (equal? (substring gimp-dir 0 1) "/") "/" "\\"))
(imgpath "")
)
; it begins here
(gimp-context-push)
(set! imgpath (car (gimp-image-get-filename img)))
(gimp-image-undo-disable img)
;logging
;(gimp-message-set-handler ERROR-CONSOLE)
;(gimp-message-set-handler CONSOLE)
;(gimp-message-set-handler MESSAGE-BOX)
;or start GIMP wwith "gimp --console-messages" to spawn a console box
;then use this:
;(gimp-message "foobar")
;testing for functions defined
;(if (defined? 'plug-in-shift) (gimp-message "It Exists") (gimp-message "Doesnt Exist"))
;set up saving
(if (= inSaveFiles TRUE)
(set! saveString
(cond
(( equal? inSaveType 0 ) ".jpg" )
(( equal? inSaveType 1 ) ".png" )
)
))
; The block below was included in the original "DivideScannedImages.scm", but seems to cause problems by adding a white border which is then subsequently sampled.
; Expand the image a bit to fix problem with images near the right edge. Probably could get away just expanding
; width but go ahead and expand height in case same issue is there...
;(set! width (+ width 30))
;(set! height (+ height 30))
;(gimp-image-resize img width height 15 15)
;(gimp-layer-resize-to-image-size inLayer)
; If the background wasn't manually defined, pick the colour from one of the four corners (using radius 3 average)
(if (not (= inDefBg TRUE))
(begin
(cond ; else
( (equal? inCorner 0)
(set! inBgCol (car (gimp-image-pick-color img inLayer inX inY TRUE TRUE 5)))
)
( (equal? inCorner 1)
(set! inBgCol (car (gimp-image-pick-color img inLayer (- width inX) inY TRUE TRUE 5)))
)
( (equal? inCorner 2)
(set! inBgCol (car (gimp-image-pick-color img inLayer inX (- height inY) TRUE TRUE 5)))
)
( (equal? inCorner 3)
(set! inBgCol (car (gimp-image-pick-color img inLayer (- width inX) (- height inY) TRUE TRUE 5)))
))
))
(gimp-image-select-color img CHANNEL-OP-REPLACE inLayer inBgCol)
(gimp-context-set-background inBgCol)
; convert inverted copy of the background selection to a path
(gimp-selection-feather img (/ (min width height) 100))
(gimp-selection-sharpen img)
(gimp-selection-invert img)
(plug-in-sel2path RUN-NONINTERACTIVE img inLayer)
;break up the vectors and loop across each vector (boundary path of each object)
(set! newpath (vector-ref (cadr (gimp-image-get-vectors img)) 0))
(set! strokes (gimp-vectors-get-strokes newpath))
(while (and (< count (car strokes)) (< numextracted inLimit))
(set! tempVector (gimp-vectors-new img "Temp"))
(gimp-image-add-vectors img (car tempVector) -1)
(gimp-vectors-stroke-new-from-points (car tempVector)
(list-ref (gimp-vectors-stroke-get-points newpath (vector-ref (cadr strokes) count)) 0)
(list-ref (gimp-vectors-stroke-get-points newpath (vector-ref (cadr strokes) count)) 1)
(list-ref (gimp-vectors-stroke-get-points newpath (vector-ref (cadr strokes) count)) 2)
(list-ref (gimp-vectors-stroke-get-points newpath (vector-ref (cadr strokes) count)) 3)
)
(gimp-vectors-to-selection (car tempVector) CHANNEL-OP-REPLACE TRUE FALSE 0 0)
;check for minimum size
(set! bounds (gimp-selection-bounds img))
(set! sizex (- (list-ref bounds 3) (list-ref bounds 1)))
(set! sizey (- (list-ref bounds 4) (list-ref bounds 2)))
(if (and (> sizex inSize) (> sizey inSize) ;min size slider
(< sizex width) (< sizey height)) ;max size image
(begin
(if (and (= inDeskew TRUE) (defined? 'gimp-deskew-plugin))
(begin
(gimp-progress-set-text "Deskewing...")
(gimp-rect-select img (list-ref bounds 1) (list-ref bounds 2)
sizex sizey CHANNEL-OP-REPLACE FALSE 0 )
(set! buffname (car (gimp-edit-named-copy inLayer buffname)))
(set! tempImage (car (gimp-edit-named-paste-as-new buffname)))
(set! tempLayer (car (gimp-image-get-active-layer tempImage)))
(gimp-image-undo-disable tempImage)
;(set! tempdisplay (car (gimp-display-new tempImage)))
(gimp-layer-flatten tempLayer)
(gimp-deskew-plugin 0 tempImage tempLayer 0 0 0 0 0)
(gimp-image-resize-to-layers tempImage)
(gimp-layer-flatten tempLayer)
(gimp-fuzzy-select tempLayer 0 0 inThreshold CHANNEL-OP-REPLACE TRUE FALSE 0 TRUE)
(gimp-selection-invert tempImage)
(set! bounds (gimp-selection-bounds tempImage))
(set! sizex (- (list-ref bounds 3) (list-ref bounds 1)))
(set! sizey (- (list-ref bounds 4) (list-ref bounds 2)))
(gimp-selection-none tempImage)
(gimp-image-crop tempImage sizex sizey (list-ref bounds 1) (list-ref bounds 2))
(if (= inSquareCrop TRUE)
(begin
(if (> sizex sizey)
(begin
(script-fu-addborder tempImage tempLayer 0 (/ (- sizex sizey) 2) inBgCol 0)
(gimp-image-raise-item-to-top tempImage tempLayer)
(gimp-image-merge-visible-layers tempImage EXPAND-AS-NECESSARY)
(set! tempLayer (car (gimp-image-get-active-layer tempImage)))
))
(if (< sizex sizey)
(begin
(script-fu-addborder tempImage tempLayer (/ (- sizey sizex) 2) 0 inBgCol 0)
(gimp-image-raise-item-to-top tempImage tempLayer)
(gimp-image-merge-visible-layers tempImage EXPAND-AS-NECESSARY)
(set! tempLayer (car (gimp-image-get-active-layer tempImage)))
))
)))
(begin
(set! tempImage img)
(set! tempLayer (car (gimp-image-get-active-layer tempImage)))
(gimp-image-undo-disable tempImage)
(if (= inSquareCrop TRUE)
(begin
(set! centroidx (* 0.5 (+ (list-ref bounds 1) (list-ref bounds 3))))
(set! centroidy (* 0.5 (+ (list-ref bounds 2) (list-ref bounds 4))))
(set! halfsidelength (+ inPadding (* 0.5 (max sizex sizey))))
(gimp-rect-select tempImage (- centroidx halfsidelength) (- centroidy halfsidelength)
(* halfsidelength 2) (* halfsidelength 2)
CHANNEL-OP-REPLACE FALSE 0 )
)
(gimp-rect-select tempImage (list-ref bounds 1) (list-ref bounds 2)
sizex sizey CHANNEL-OP-REPLACE FALSE 0)
)
(set! buffname (car (gimp-edit-named-copy inLayer buffname)))
(set! tempImage (car (gimp-edit-named-paste-as-new buffname)))
(set! tempLayer (car (gimp-image-get-active-layer tempImage)))
)
)
(set! tempdisplay (car (gimp-display-new tempImage)))
(if (> inPadding 0)
(begin
(script-fu-addborder tempImage tempLayer inPadding inPadding inBgCol 0)
(gimp-image-merge-visible-layers tempImage EXPAND-AS-NECESSARY)
(set! tempLayer (car (gimp-image-get-active-layer tempImage)))
))
(gimp-image-undo-enable tempImage)
;save file
(if (= inSaveFiles TRUE)
(begin
(let* ((targetDir inDir))
(if (= inSaveInSourceDir TRUE)
(set! targetDir (unbreakupstr (butlast (strbreakup imgpath pathchar)) pathchar))
)
(set! newFileName (string-append targetDir pathchar inFileName
(substring "00000" (string-length (number->string (+ inFileNumber numextracted))))
(number->string (+ inFileNumber numextracted)) saveString))
(gimp-image-set-resolution tempImage 600 600) ; The DPI
(if (equal? saveString ".jpg")
(file-jpeg-save RUN-NONINTERACTIVE tempImage tempLayer newFileName newFileName inJpgQual 0.1 1 0 "Custom JPG compression by FrancoisM" 0 1 0 1)
(gimp-file-save RUN-NONINTERACTIVE tempImage tempLayer newFileName newFileName)
)
(if (= inAutoClose TRUE)
(begin
(gimp-display-delete tempdisplay)
)
)
)
))
(set! numextracted (+ numextracted 1))
)
)
(gimp-image-remove-vectors img (car tempVector))
(set! count (+ count 1))
)
;input drawable name should be set to 1919191919 if in batch
(if (and (> numextracted 0) (equal? (car (gimp-drawable-get-name inLayer)) "1919191919"))
(gimp-drawable-set-name inLayer (number->string (+ 1919191919 numextracted))))
;delete temp path
(gimp-image-remove-vectors img newpath)
(gimp-selection-none img)
;done
(gimp-image-undo-enable img)
(gimp-progress-end)
(gimp-displays-flush)
(gimp-context-pop)
)
)
(script-fu-register "script-fu-isolate-images-on-background"
"<Image>/Filters/Isolate Images on Background"
"Isolates images from a uniform background and saves a new square image for each."
"(c) by nobisoft (based on work by Francois Malan)"
"nobi (based on work by Francois Malan)"
"Jan 2020"
"RGB* GRAY*"
SF-IMAGE "image" 0
SF-DRAWABLE "drawable" 0
SF-TOGGLE "Force square crop" FALSE
SF-ADJUSTMENT "Square border padding (pixels)" (list 0 0 100 1 10 0 SF-SLIDER)
SF-ADJUSTMENT "Max number of items" (list 10 1 100 1 10 0 SF-SLIDER)
SF-TOGGLE "Run Deskew" TRUE
SF-TOGGLE "Auto-close sub-images after saving" TRUE
SF-ADJUSTMENT "Selection Threshold" (list 25 0 255 1 10 1 SF-SLIDER)
SF-ADJUSTMENT "Size Threshold" (list 100 0 2000 10 100 1 SF-SLIDER)
SF-TOGGLE "Manually define background colour" FALSE
SF-COLOR "Manual background colour" '(255 255 255)
SF-OPTION "Auto-background sample corner" (list "Top Left" "Top Right" "Bottom Left" "Bottom Right")
SF-ADJUSTMENT "Auto-background sample x-offset" (list 25 5 100 1 10 1 SF-SLIDER)
SF-ADJUSTMENT "Auto-background sample y-offset" (list 25 5 100 1 10 1 SF-SLIDER)
SF-TOGGLE "Save output to source directory" TRUE
SF-DIRNAME "Target directory (if not to source)" ""
SF-OPTION "Save File Type" (list "jpg" "png")
SF-ADJUSTMENT "JPG Quality" (list 0.8 0.1 1.0 1 10 1 SF-SLIDER)
SF-STRING "Save File Base Name" "Crop"
SF-ADJUSTMENT "Save File Start Number" (list 1 0 9000 1 100 0 SF-SPINNER)
)
; nobi: Jan 2020
(define (filename-basename fileName)
;; Return the base part of a fileName, i.e. without directory/volume and without extension
;; credits to https://stackoverflow.com/questions/1386293/how-to-parse-out-base-file-name-using-script-fu
(let* (
(pathSep (if (equal? (substring gimp-dir 0 1) "/") "/" "\\"))
(tail (car (reverse (strbreakup fileName pathSep))))
)
(unbreakupstr (reverse (cdr (reverse (strbreakup tail ".")))) ".")
)
)
; nobi: Jan 2020
(define (non-empty-directory? fileName)
;; Return true if fileName designates a non-empty directory
(let* (
(pathSep (if (equal? (substring gimp-dir 0 1) "/") "/" "\\"))
)
(< 0 (car (file-glob (string-append fileName pathSep "*") 1)))
)
)
; nobi: Jan 2020
(define (file-glob-recursively dirName globStr encoding)
;; Return a list of all files in dirName or its subdirectories which match globstr
;; credits to https://stackoverflow.com/questions/7806198/how-to-get-a-list-of-files-jpg-from-all-folders
; Another idea:
; (define (recurse-or-nil-or-match fileName)
; (cond (
; ((non-empty-directory? fileName) (file-glob-recursively fileName globStr))
; ((matches? globStr (tail fileName)) (list fileName))
; (#t '())
; )
; )
; then do:
; (append-map recurse-or-nil-or-match allFiles)
(let* (
(pathSep (if (equal? (substring gimp-dir 0 1) "/") "/" "\\"))
(allFiles (cadr (file-glob (string-append dirName pathSep "*") 1)))
(subDirs (filter non-empty-directory? allFiles))
(matchingFiles (cadr (file-glob (string-append dirName pathSep globStr) encoding)))
)
(while (not (null? subDirs))
(set! matchingFiles (append matchingFiles (cadr (file-glob-recursively (car subDirs) globStr encoding))))
(set! subDirs (cdr subDirs))
)
(list (length matchingFiles) matchingFiles)
)
)
; nobi Jan 2020
; Added Boolean inRecurseDirectories, to indicate that directories shall be searched recursively
; Added Boolean inUseFileNameAsBase, to indicate that the original file's base name shall be used with a counter, instead of inFileName
(define (script-fu-batch-isolate-images-on-background
inSourceDir
inRecurseDirectories ; nobi: added
inLoadType
inSquareCrop
inPadding
inLimit
inDeskew
inAutoClose
inThreshold
inSize
inDefBg
inBgCol
inCorner
inX
inY
inSaveInSourceDir
inDestDir
inSaveType
inJpgQual
inUseFileNameAsBase ; nobi: added
inFileName
inFileNumber
)
(let* (
(varLoadStr "")
(varFileList 0)
(varCounter inFileNumber)
(pathchar (if (equal? (substring gimp-dir 0 1) "/") "/" "\\"))
)
(define split
(lambda (ls)
(letrec ((split-h (lambda (ls ls1 ls2)
(cond
((or (null? ls) (null? (cdr ls)))
(cons (reverse ls2) ls1))
(else (split-h (cddr ls)
(cdr ls1) (cons (car ls1) ls2)))))))
(split-h ls ls '()))))
(define merge
(lambda (pred ls1 ls2)
(cond
((null? ls1) ls2)
((null? ls2) ls1)
((pred (car ls1) (car ls2))
(cons (car ls1) (merge pred (cdr ls1) ls2)))
(else (cons (car ls2) (merge pred ls1 (cdr ls2)))))))
;pred is the comparison, i.e. <= for an ascending numeric list, or
;string<=? for a case sensitive alphabetical sort,
;string-ci<=? for a case insensitive alphabetical sort,
(define merge-sort
(lambda (pred ls)
(cond
((null? ls) ls)
((null? (cdr ls)) ls)
(else (let ((splits (split ls)))
(merge pred
(merge-sort pred (car splits))
(merge-sort pred (cdr splits))))))))
;begin here
(set! varLoadStr
(cond
(( equal? inLoadType 0 ) ".[jJ][pP][gG]" )
(( equal? inLoadType 1 ) ".[jJ][pP][eE][gG]" )
(( equal? inLoadType 2 ) ".[bB][mM][pP]" )
(( equal? inLoadType 3 ) ".[pP][nN][gG]" )
(( equal? inLoadType 4 ) ".[tT][iI][fF]" )
(( equal? inLoadType 5 ) ".[tT][iI][fF][fF]" )
)
)
; nobi: determine list of files differently when recursion is requested
(if inRecurseDirectories
(let ((files (cadr (file-glob-recursively inSourceDir (string-append "*" varLoadStr) 1))))
(write files) (newline)
(set! varFileList (merge-sort string<=? files))
)
(set! varFileList (merge-sort string<=? (cadr (file-glob (string-append inSourceDir pathchar "*" varLoadStr) 1))))
)
(while (not (null? varFileList))
(let* ((filename (car varFileList))
(image (car (gimp-file-load RUN-NONINTERACTIVE filename filename)))
(drawable (car (gimp-image-get-active-layer image)))
(fragmentFileName inFileName)
)
; nobi: if requested, use original file name as base
(if (= inUseFileNameAsBase TRUE)
(set! fragmentFileName (string-append (filename-basename filename) "-"))
)
;flag for batch mode
(gimp-drawable-set-name drawable "1919191919")
(gimp-progress-set-text (string-append "Working on ->" filename))
(script-fu-isolate-images-on-background image
drawable
inSquareCrop
inPadding
inLimit
inDeskew
inAutoClose
inThreshold
inSize
inDefBg
inBgCol
inCorner
inX
inY
inSaveInSourceDir
inDestDir
inSaveType
inJpgQual
fragmentFileName ; nobi: changed from inFileName
varCounter)
;increment by number extracted.
; nobi: if using file name as base, restart numbering for every original file
(if (= inUseFileNameAsBase TRUE)
(set! varCounter inFileNumber)
(set! varCounter (+ varCounter (- (string->number (car (gimp-drawable-get-name drawable))) 1919191919)))
)
(gimp-image-delete image)
)
(set! varFileList (cdr varFileList))
)
)
)
(script-fu-register "script-fu-batch-isolate-images-on-background"
"<Toolbox>/Xtns/Batch Tools/Isolate Images on Background..."
"Isolate (and save) images in a background, for many files at once."
"(c) by nobisoft (based on work of Francois Malan)"
"nobi (based on work of Francois Malan)"
"Jan 2020"
""
SF-DIRNAME "Load from" ""
SF-TOGGLE "Recurse into subdirectories" FALSE ; nobi: added
SF-OPTION "Load file type" (list "jpg" "jpeg" "bmp" "png" "tif" "tiff")
SF-TOGGLE "Force square crop" FALSE
SF-ADJUSTMENT "Square border padding (pixels)" (list 0 0 100 1 10 0 SF-SLIDER)
SF-ADJUSTMENT "Max number of photographs" (list 10 1 100 1 10 0 SF-SLIDER)
SF-TOGGLE "Deskew (if deskew.exe installed)" TRUE
SF-TOGGLE "Close isolated images after saving" TRUE
SF-ADJUSTMENT "Selection Threshold" (list 25 0 255 1 10 1 SF-SLIDER)
SF-ADJUSTMENT "Min photograph size" (list 100 0 2000 10 100 1 SF-SLIDER)
SF-TOGGLE "Manually define background colour" FALSE
SF-COLOR "Manual background colour" '(255 255 255)
SF-OPTION "Auto-background sample corner" (list "Top Left" "Top Right" "Bottom Left" "Bottom Right")
SF-ADJUSTMENT "Auto-background sample x-offset" (list 25 5 100 1 10 1 SF-SLIDER)
SF-ADJUSTMENT "Auto-background sample y-offset" (list 25 5 100 1 10 1 SF-SLIDER)
SF-TOGGLE "Save output to source directory" TRUE
SF-DIRNAME "Target directory (if not to source)" ""
SF-OPTION "Save file type" (list "jpg" "png")
SF-ADJUSTMENT "JPG quality" (list 0.8 0.1 1.0 1 10 1 SF-SLIDER)
SF-TOGGLE "Use filename as base" FALSE ; nobi: added
SF-STRING "Save File Base Name" "Crop"
SF-ADJUSTMENT "Save File Start Number" (list 1 0 9000 1 100 0 SF-SPINNER)
)