GIMP Script-fu

Artifact [6772bc744c]
Login

Artifact 6772bc744ceb60d59cdcb37f2526fea9a55d9cac:


; 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 (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 thumbail-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))
      (gimp-floating-sel-anchor 
        (car (gimp-text-fontname table-image 
                                 table-layer
                                 (+ (car v-grid) 9)
                                 (+ (car h-grid) 6)
                                 "ROW"
                                 0
                                 TRUE
                                 20
                                 PIXELS
                                 "Sans Bold" )))
      (gimp-floating-sel-anchor 
        (car (gimp-text-fontname table-image 
                                 table-layer
                                 (+ (cadr v-grid) 6)
                                 (+ (car h-grid) 6)
                                 "READ"
                                 0
                                 TRUE
                                 20
                                 PIXELS
                                 "Sans Bold" )))
      (let loop ((xs (cddr (butlast v-grid)))
                 (text? #f) )
        (gimp-progress-pulse)
        (unless (null? xs)
          (gimp-floating-sel-anchor
            (car (gimp-text-fontname table-image 
                                     table-layer
                                     (+ (car xs) 16)
                                     (+ (car h-grid) 6)
                                     (if text?
                                       "S"
                                       "O" )
                                     0
                                     TRUE
                                     20
                                     PIXELS
                                     "Sans Bold" )))
          (loop (cdr xs)
                (not text?) )))
      (gimp-context-pop)
      table-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" )))))
                                 
  ; 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) ))))))))
        (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)
        ; Our tables need to be filled from bottom of the scanned image to its top
        (set! rows (reverse rows))
        ; 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"
  "<Image>/File/Create"
  )