; 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 '(210 245 280 315 350 385 420 455 490 525 560 595 630 665 700 735 770 805 840 875 910 945 )) ; 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) (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))) (buffer (car (gimp-edit-named-copy orig-drawable "BG"))) (thumbnail-layer 0) (brush (car (gimp-brush-new "temp-brush"))) ) (gimp-image-undo-disable table-image) (gimp-image-add-layer table-image table-layer 0) (gimp-drawable-fill table-layer WHITE-FILL) (set! thumbnail-layer (car (gimp-edit-named-paste table-layer buffer TRUE))) (gimp-buffer-delete buffer) ; insert thumbnail image in upper right corner (let* ((layer-width (car (gimp-drawable-width thumbnail-layer))) (layer-height (car (gimp-drawable-height thumbnail-layer))) (aspect (/ layer-height layer-width)) ) (if (< (/ 300 layer-width) (/ 190 layer-height)) (begin (gimp-layer-scale-full thumbnail-layer 300 (* 300 aspect) TRUE INTERPOLATION-LANCZOS) (gimp-layer-set-offsets thumbnail-layer (- (car (last v-grid)) 300) (+ 10 (/ (- 190 (* 300 aspect)) 2)) )) (begin (gimp-layer-scale-full thumbnail-layer (/ 190 aspect) 190 TRUE INTERPOLATION-LANCZOS) (gimp-layer-set-offsets thumbnail-layer (- (car (last v-grid)) (/ 190 aspect)) 10 )))) (gimp-floating-sel-anchor thumbnail-layer) (gimp-context-push) (gimp-context-set-foreground '(0 0 0)) (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 "Creating page...") (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 20))) (remaining-rows (cdr (split rows 20))) (page-num 1) (row-grid h-grid) (tables '()) ) (if (null? page-rows) (if (null? remaining-rows) tables ; Done! (page-loop (car (split remaining-rows 20)) (cdr (split remaining-rows 20)) (succ page-num) h-grid tables )) (begin (let* ((table-image (create-table-image)) (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" "/File/Create" )