GIMP Script-fu

Artifact [ce74fc40d0]
Login

Artifact ce74fc40d07ee8dc871fcc6394e3ab5e7482bfbe:


; 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)
  ; Splits a list at k'th element
  (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)
    (gimp-progress-set-text "Creating page...")
    (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)))
           (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 ))
           (h-grid '(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 ))
           (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)
      (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)
      (let loop ((v-lines v-grid)) ; paint horizontal lines
        (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
        (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
        (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) )
        (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
      )
    )

  ; MAIN processing starts here
  (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))) )
    (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)
        ; First 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 ((v-grid '( 65 140 215 265 315 365 415 465 515 
                        565 615 665 715 765 815 865 915 965 1015 
                        1065 1115 1165 ))
              (h-grid '(140 175 210 245 280 315 350 385 420
                        455 490 525 560 595 630 665 700 735 770 
                        805 840 875 910 )))

          (let page-loop ((page-rows (car (split rows 23)))
                          (remaining-rows (cdr (split rows 23)))
                          (page-num 1)
                          (row-grid h-grid) )
            (if (null? page-rows)
              (if (null? remaining-rows)
                page-num ; Done!
                (page-loop (car (split remaining-rows 23))
                           (cdr (split remaining-rows 23))
                           (succ page-num)
                           h-grid ))
              (begin
                (let* ((table-image (create-table-image))
                       (table-layer (car (gimp-image-get-active-layer table-image))) )
                  (gimp-progress-set-text "Filling table...")
                  (gimp-image-undo-disable table-image)
                  (gimp-display-new table-image)
                  (let line-loop ((line-rows page-rows)
                                  (row-offsets h-grid)
                                  (line-cnt (length page-rows)) )
                    (unless (or (null? line-rows) (zero? line-cnt))
                      (let* ((num-text (caar line-rows))
                             (text-width (car (gimp-text-get-extents-fontname num-text
                                                                              20
                                                                              PIXELS
                                                                              "Sans Bold" ))))
                        (gimp-floating-sel-anchor ; row number
                          (car (gimp-text-fontname table-image 
                                                   table-layer
                                                   (+ (car v-grid) 
                                                      (/ (- (cadr v-grid) 
                                                            (car v-grid) )
                                                         2 )
                                                      (- (/ text-width 2)) )
                                                   (+ (car row-offsets) 6)
                                                   num-text
                                                   0
                                                   TRUE
                                                   20
                                                   PIXELS
                                                   "Sans Bold" )))
                        (gimp-floating-sel-anchor ; read direction
                          (car (gimp-text-fontname table-image 
                                                   table-layer
                                                   (+ (cadr v-grid) 28)
                                                   (+ (car row-offsets) 6)
                                                   (if (string=? num-text "---")
                                                     "-"
                                                     (if (even? (string->number num-text))
                                                       "L"
                                                       "R" ))
                                                   0
                                                   TRUE
                                                   20
                                                   PIXELS
                                                   "Sans Bold" ))))
                      (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) )
                          (let* ((text (number->string (car cells)))
                                 (text-width (car (gimp-text-get-extents-fontname text
                                                                                  20
                                                                                  PIXELS
                                                                                 "Sans Bold" ))))
                            (gimp-floating-sel-anchor ; row number
                              (car (gimp-text-fontname table-image 
                                                       table-layer
                                                       (+ (car col-grid) 
                                                          (/ (- (cadr col-grid) 
                                                                (car col-grid) )
                                                             2 )
                                                          (- (/ text-width 2)) )
                                                       (+ (car row-offsets) 6)
                                                       text
                                                       0
                                                       TRUE
                                                       20
                                                       PIXELS
                                                       "Sans Bold" )))
                            (cell-loop (cdr cells)
                                       (cdr col-grid)
                                       (pred cell-cnt) ))))
                      (line-loop (cdr line-rows)
                                 (cdr row-offsets)
                                 (pred line-cnt) )))
                  (gimp-image-undo-enable table-image)
                  (page-loop '()
                             remaining-rows
                             (succ page-num)
                             h-grid )))))
              )))
    (gimp-displays-flush)
    (gimp-progress-end) ))
     
(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"
  )