;;;
;;; Copyright (C) 2002-2022 The FreeCol Team
;;;
;;; This file is part of FreeCol.
;;;
;;; FreeCol 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.
;;;
;;; FreeCol 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.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with FreeCol. If not, see <http://www.gnu.org/licenses/>.
;;;
(define half-x 64)
(define half-y 32)
(define half-width 20)
(define half-height 10)
;;; Increment a binary number represented as a list of ones and zeros,
;;; starting with the least significant bit. Return #f if the number
;;; can not be incremented without adding another bit.
(define increment
(lambda (lst)
(let loop ((remaining lst)
(result '()))
(if (null? remaining)
#f
(if (= 0 (car remaining))
(append (reverse (cons 1 result))
(cdr remaining))
(loop (cdr remaining)
(cons 0 result)))))))
;;; Calculate the point on the line defined by the given point and
;;; slope, at x0.
(define calculate-point
(lambda (point slope x0)
(let* ((x (car point))
(y (cadr point))
(b (- y (* slope x))))
(list x0 (+ (* slope x0) b)))))
(define script-fu-cut-forests
(lambda (img drawable)
(let* ((height (car (gimp-image-height img)))
(offset (- height 64))
(north
(list half-x (+ offset (- half-y half-height))))
(east
(list (+ half-x half-width) (+ offset half-y)))
(south
(list half-x (+ offset half-y half-height)))
(west
(list (- half-x half-width) (+ offset half-y)))
(north-east
(list north (calculate-point north -0.5 128)
(calculate-point east -0.5 128)))
(south-east
(list east (calculate-point east 0.5 128)
(calculate-point south 0.5 128)))
(south-west
(list south (calculate-point south -0.5 0)
(calculate-point west -0.5 0)))
(north-west
(list west (calculate-point west 0.5 0)
(calculate-point north 0.5 0) north))
(rectangles
(list north-east south-east south-west north-west)))
(let loop ((count '(1 0 0 0)))
(if count
(let* ((image (car (gimp-image-duplicate img)))
(pic-layer (car (gimp-image-get-active-drawable image)))
(vec (car (gimp-vectors-new image "points"))))
(gimp-image-undo-disable image)
(gimp-image-undo-group-start image)
(gimp-selection-none image)
(gimp-image-add-vectors image vec -1)
(let branch-loop ((branches count)
(rectangles rectangles)
(result '()))
(if (null? branches)
(let ((points
(apply append (map (lambda (n) (append n n n)) result))))
(gimp-vectors-stroke-new-from-points
vec 0 (length points) (list->vector points) TRUE))
(let ((branch (car branches))
(rectangle (car rectangles)))
(branch-loop (cdr branches)
(cdr rectangles)
(append result
(if (= 1 branch)
rectangle
(list (car rectangle))))))))
(let* ((current-name (car (gimp-image-get-filename img)))
(name (substring current-name 0 (- (string-length current-name) 4))))
(gimp-vectors-to-selection
vec
CHANNEL-OP-ADD
TRUE FALSE 0 0)
(gimp-edit-clear pic-layer)
(file-png-save-defaults
1 image pic-layer
(string-append
name
(apply string-append (map number->string count))
".png") "")
(loop (increment count)))))))))
(script-fu-register "script-fu-cut-forests"
_"Cut forests"
_"Cut forests"
"Michael Vehrs <Michael.Burschik@gmx.de>"
"Michael Vehrs"
"2012-10-27"
"RGB GRAY"
SF-IMAGE "Image" 0
SF-DRAWABLE "Drawable" 0)
(script-fu-menu-register "script-fu-cut-forests"
"<Image>/Filters")