; 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.
(define (script-fu-sg-viktoria orig-image orig-drawable)
(define v-grid '( 65 140 215 265 315 365 415 465 515 565 615
665 715 765 815 865 915 965 1015 1065 1115 1165 1215 ))
(define h-grid '(070 105 140 175 210 245 280 315 350 385 420 455 490 525
560 595 630 665 700 735 770 805 840 875 910 945 980 ))
; Splits a list at k'th element
; Returns a pair of lists ((prefix) . (suffix))
(define (split lis k)
(let loop ((suffix lis)
(prefix '())
(k (min k (length lis))) )
(if (zero? k)
(cons (reverse prefix) suffix)
(loop (cdr suffix)
(cons (car suffix) prefix)
(pred k) ))))
(define (row-solid? image drawable y)
(let ((color (vector->list (cadr (gimp-drawable-get-pixel drawable 0 y))))
(width (car (gimp-image-width image))) )
(gimp-rect-select image 0 y width 1 CHANNEL-OP-REPLACE 0 0)
(gimp-by-color-select drawable
color
1
CHANNEL-OP-SUBTRACT
FALSE
FALSE
0
0 ) )
(not (zero? (car (gimp-selection-is-empty image)))) )
(define (col-solid? image drawable x)
(let ((color (vector->list (cadr (gimp-drawable-get-pixel drawable x 0))))
(height (car (gimp-image-height image))) )
(gimp-rect-select image x 0 1 height CHANNEL-OP-REPLACE 0 0)
(gimp-by-color-select drawable
color
1
CHANNEL-OP-SUBTRACT
FALSE
FALSE
0
0 ))
(not (zero? (car (gimp-selection-is-empty image)))) )
(define (place-text layer text x-list y-list)
(let ((image (car (gimp-drawable-get-image layer)))
(text-width (car (gimp-text-get-extents-fontname text
20
PIXELS
"Sans Bold" ))) )
(gimp-floating-sel-anchor
(car (gimp-text-fontname image
layer
(+ (car x-list)
(/ (- (cadr x-list)
(car x-list) )
2 )
(- (/ text-width 2)) )
(+ (car y-list) 6)
text
0
TRUE
20
PIXELS
"Sans Bold" )))))
(define (create-table-image page-num)
(let* ((table-image (car (gimp-image-new 1280 1024 RGB)))
(table-layer (car (gimp-layer-new table-image 1280 1024 RGB-IMAGE "Table" 100 NORMAL-MODE)))
(brush (car (gimp-brush-new "temp-brush")))
(page-string (string-append "Page "
(number->string page-num) )))
(gimp-image-undo-disable table-image)
(gimp-image-add-layer table-image table-layer 0)
(gimp-drawable-fill table-layer WHITE-FILL)
(gimp-context-push)
(gimp-context-set-foreground '(0 0 0))
(gimp-floating-sel-anchor
(car (gimp-text-fontname table-image
table-layer
(- (car (gimp-image-width table-image))
(car (gimp-text-get-extents-fontname page-string
24
PIXELS
"Sans Bold" ))
65 )
25
page-string
0
TRUE
20
PIXELS
"Sans Bold" )))
(gimp-brush-set-radius brush 1)
(gimp-context-set-paint-method "gimp-paintbrush")
(gimp-context-set-brush brush)
(gimp-context-set-paint-mode NORMAL-MODE)
(gimp-progress-pulse)
(gimp-progress-set-text (string-append "Creating "
page-string
"..." ))
(let loop ((v-lines v-grid)) ; paint horizontal lines
(gimp-progress-pulse)
(unless (null? v-lines)
(gimp-paintbrush table-layer 0 4
(vector (car v-lines) (car h-grid) (car v-lines) (car (last h-grid)))
PAINT-CONSTANT
0 )
(loop (cdr v-lines)) ))
(let loop ((h-lines h-grid)) ; paint vertical lines
(gimp-progress-pulse)
(unless (null? h-lines)
(gimp-paintbrush table-layer 0 4
(vector (car v-grid) (car h-lines) (car (last v-grid)) (car h-lines))
PAINT-CONSTANT
0 )
(loop (cdr h-lines)) ))
(let loop-cols ((xs (cdddr v-grid))) ; select grayed cells
(gimp-progress-pulse)
(unless (null? xs)
(let loop-rows ((ys (butlast h-grid)) )
(if (null? ys)
(loop-cols (cddr xs))
(begin
(gimp-image-select-contiguous-color table-image
CHANNEL-OP-ADD
table-layer
(+ (car xs) 2)
(+ (car ys) 2) )
(loop-rows (cdr ys)) )))))
(gimp-context-set-foreground '(228 228 228))
(gimp-edit-fill table-layer FOREGROUND-FILL)
(gimp-selection-none table-image)
(gimp-brush-delete brush)
(gimp-context-set-foreground '(0 0 0))
(place-text table-layer "ROW" v-grid h-grid)
(place-text table-layer "READ" (cdr v-grid) h-grid)
(let loop ((xs (cddr v-grid))
(text? #f) )
(gimp-progress-pulse)
(unless (null? (cdr xs))
(place-text table-layer (if text? "S" "O") xs h-grid)
(loop (cdr xs)
(not text?) )))
(gimp-context-pop)
table-image
)
)
; MAIN processing starts here
(gimp-context-push)
(let* ((width (car (gimp-drawable-width orig-drawable)))
(height (car (gimp-drawable-height orig-drawable)))
(buffer (car (gimp-edit-named-copy orig-drawable "BG")))
(image (car (gimp-edit-named-paste-as-new buffer)))
(layer (car (gimp-image-flatten image))) )
(gimp-buffer-delete buffer)
(unless (zero? (car (gimp-image-base-type image)))
(gimp-image-convert-rgb image) )
(gimp-image-convert-indexed image
NO-DITHER
MAKE-PALETTE
3
FALSE
FALSE
"")
(gimp-image-convert-rgb image)
(plug-in-autocrop RUN-NONINTERACTIVE image layer)
(set! width (car (gimp-image-width image)))
(set! height (car (gimp-image-height image)))
(gimp-progress-pulse)
(gimp-progress-set-text "Scanning...")
(let ((rows (let loop ((y 0)
(rows '()) )
(gimp-progress-pulse)
(while (and (< y height) (row-solid? image layer y) )
(set! y (succ y)) )
(let ((start-row y))
(while (and (< y height) (not (row-solid? image layer y)) )
(set! y (succ y)) )
(if (= start-row y)
(reverse rows)
(loop (succ y)
(cons (cons start-row y) rows) ))))))
(let ((cols (let loop ((x 0)
(cols '()) )
(gimp-progress-pulse)
(while (and (< x width) (col-solid? image layer x) )
(set! x (succ x)) )
(let ((start-col x))
(while (and (< x width) (not (col-solid? image layer x)) )
(set! x (succ x)) )
(if (= start-col x)
(reverse cols)
(loop (succ x)
(cons (cons start-col x) cols) ))))))
(set! rows (map (lambda (x) (/ (+ (car x) (cdr x)) 2)) rows))
(set! cols (map (lambda (x) (/ (+ (car x) (cdr x)) 2)) cols))
(gimp-selection-none image)
(gimp-threshold layer 127 255)
(gimp-image-convert-grayscale image)
(set! rows
(let loop-rows ((rows rows)
(row-result '()) )
(if (null? rows)
(reverse row-result)
(let ((row (map (lambda (x)
(zero? (vector-ref (cadr (gimp-drawable-get-pixel layer x (car rows))) 0)) )
cols) ))
(let rle ((cols row)
(result '()) )
(let ((rest (member (not (car cols)) cols)))
(if rest
(rle rest
(cons (cons (car cols) (- (length cols) (length rest))) result) )
(loop-rows (cdr rows)
(cons (cons (cons (car cols) (length cols)) result) row-result) ))))))))
; Our tables need to be filled from bottom of the scanned image to its top
(set! rows (reverse rows))
; Now we need to reverse direction for every other row
(set! rows
(let loop ((rows rows)
(result '())
(rvs? #f) )
(if (null? rows)
(reverse result)
(loop (cdr rows)
(cons (if rvs? (reverse (car rows))
(car rows) )
result )
(not rvs?) ))))
; At this point we have a list of row information, ready to create our table
(gimp-image-delete image)
; Next we need to ensure that each row starts with an OPEN run (possibly of zero length)
(set! rows
(let loop ((rows rows)
(result '()) )
(if (null? rows)
(reverse result)
(if (caaar rows)
(loop (cdr rows)
(cons (cons 0 (map cdr (car rows))) result) )
(loop (cdr rows)
(cons (map cdr (car rows)) result) )))))
; Next we prepend a row number to each row and insure each line
; has no more than 20 cells.
(set! rows
(let loop ((rows rows)
(row-num 1)
(continued? #f)
(result '()) )
(if (pair? rows)
(let ((remaining (cdr (split (car rows) 20)))
(this-row (car (split (car rows) 20))) )
(if (pair? remaining)
(loop (cons remaining (cdr rows))
row-num
#t
(append result (list (cons (if continued?
"---"
(number->string row-num) )
this-row))) )
(loop (cdr rows)
(succ row-num)
#f
(append result (list (cons (if continued?
"---"
(number->string row-num) )
this-row))) )))
result )))
(gimp-context-set-foreground '(0 0 0))
(let ((h-grid (cdr h-grid)))
(let ((images
(let page-loop ((page-rows (car (split rows 25)))
(remaining-rows (cdr (split rows 25)))
(page-num 1)
(row-grid h-grid)
(tables '()) )
(if (null? page-rows)
(if (null? remaining-rows)
tables ; Done!
(page-loop (car (split remaining-rows 25))
(cdr (split remaining-rows 25))
page-num
h-grid
tables ))
(begin
(let* ((table-image (create-table-image page-num))
(table-layer (car (gimp-image-get-active-layer table-image))) )
(gimp-progress-pulse)
(gimp-progress-set-text "Filling table...")
(set! tables (cons table-image tables))
(let line-loop ((line-rows page-rows)
(row-offsets h-grid)
(line-cnt (length page-rows)) )
(unless (or (null? line-rows) (zero? line-cnt))
(place-text table-layer (caar line-rows) v-grid row-offsets)
(let ((num-text (caar line-rows)))
(place-text table-layer num-text v-grid row-offsets)
(place-text table-layer
(if (string=? num-text "---")
"-"
(if (even? (string->number num-text))
"L"
"R" ))
(cdr v-grid)
row-offsets ))
(let cell-loop ((cells (cdar line-rows))
(col-grid (cddr v-grid)) ; skip the 'row' and 'read' columns
(cell-cnt 20) )
(gimp-progress-pulse)
(unless (or (zero? cell-cnt)
(null? cells) )
(place-text table-layer (number->string (car cells)) col-grid row-offsets)
(cell-loop (cdr cells)
(cdr col-grid)
(pred cell-cnt) )))
(line-loop (cdr line-rows)
(cdr row-offsets)
(pred line-cnt) ))))
(page-loop '()
remaining-rows
(succ page-num)
h-grid
tables ))))))
(let loop ((images images))
(unless (null? images)
(gimp-image-undo-enable (car images))
(gimp-display-new (car images))
(loop (cdr images)) ))
))))
(gimp-displays-flush)
(gimp-progress-end)
)
(gimp-context-pop)
)
(script-fu-register "script-fu-sg-viktoria"
"_Crochet Pattern by Viktoria"
"Create crochet instructions per Viktoria"
"Saul Goode"
"Saul Goode"
"April 2013"
"*"
SF-IMAGE "Image" 0
SF-DRAWABLE "Drawable" 0
)
(script-fu-menu-register "script-fu-sg-viktoria"
"<Image>/File/Create"
)
|