; GIMP Parametric curves
; Copyright (c) 2010 Georges Brougnard
; echolalie@echolalie.com
; ---------------------------------------------------------------------
; 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 3 of the License, or
; (at your from-lib) 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.
; You should have received a copy of the GNU General Public License
; along with this program. If not, see .
; ================== Version BETA 0.1 ================
;
;=================== DOCUMENTATION =============================
;http://www.echolaliste.com/gimp/script-fu-parametriccurves.html
;http://www.echolalie.org/gimp//script-fu-parametriccurves.html (later)
;===============================================================
; Refs
; http://tinyscheme.sourceforge.net/tinyscm.txt
; http://registry.gimp.org/
; http://schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_idx_532
; http://www.answers.com/topic/butterfly-curve-transcendental
;
;---------------------------------------------------------------------
; G-LIBRARY FORMAT
; ("title" x(t) y(t) r(t) sx() sy() "prog" *tmin* *tmax* *resolution* origin *shape* )
;
;----------------------------------------------------------------------
(define (lib-get liblist lib)
(let* ((lg (- (length liblist) 4)))
(if (< lib lg )
(list-ref liblist lib)
(catch (begin (msg "cannot find lib:" (car (list-ref liblist lib))) (list-ref liblist 1))
(cons (car (list-ref liblist lib)) (read (open-input-string (car(gimp-gimprc-query (cadr (list-ref liblist lib)))))))))))
(define *G-LIBRARY* '(
("* CURVE DEFINITION *") ; idx 0 not used
("xy-Axis" "if((C=1) 0 t)" "if((C=1) t 0)" "" "0" "0" "loop(2)" "-10" "10" 20 0 0)
("Surf" "t+ sin(2*t)" "sin(3*t)* cos(t)" "" "0" "2" "" "-10" "10" 200 0 0 )
("Butterfly" "" "" "exp(cos(t)) - 2*cos(4*t) - pow(sin(t/12),5)" "0" "0" "" "0" "24*PI" 2000 0 0)
("Brougnard's sequence" "i" "if((i=0) rand(100) if ((.y % 3 = 2) prime((.y-1)/2) prime(.y*2)))" "" "0" "0" "" "0" "100" 100 1 3 )
("Crunodal cubic" "t*t-1" "t*x" "" "0" "0" "" "-1.5" "1.5" 200 0 0 )
("Talbot's curve" "(sin(t)*sin(t) + 1.1)*cos(t)" "(sin(t)*sin(t) + 1.1 - 2)*sin(t)" "" "1.5" "0.5" "" "-PI" "PI" 200 0 0 )
("Spring" "100*cos(7*t)" "150 * sin(3*t)" "" "200" "200" "" "-PI" "PI" 400 0 0)
("Gauss" "t" "gauss(x,P(1))" "" "0" "2" "loop(6 P(1,0.25*C))" "-4" "4" 200 3 0)
("Fibonacci" "t" "if((i<2) 1 (.y + ..y))" "" "0" "0" "" "0" "12" 12 1 3)
("Polar" "" "" "1+0.2*sin(3*t)*sin((100/7)*t)" "0" "0" "" "0" "7*2PI" 2000 0 0)
("Logarithmic cartoon" "" "" "if((i>250) noise(4.5) log(1+t))" "0" "0" "param(cartoon(2) color(255,0,0))" "0" "100" 500 0 0)
("History-1" "paramoid-1") ; user in gimprc
("History-2" "paramoid-2")
("History-3" "paramoid-3")
("History-4" "paramoid-4")
))
;fonction X = sin(t)*(1.0 + 0.2*sin(3.2*t)), fonction Y = cos(t)*(1.0 + 0.2*sin(3.2*t)).
;--------------------------------------------------
;C-LIKE enums
;--------------------------------------------------
(define (def-enum l i ) (if (pair? l) (cons (list 'define (car l) i) (def-enum (cdr l) (+ 1 i) )) ()))
(define (do-enum enums) (cons 'begin (def-enum enums 0)))
(define *enums* '(
(G-OPTION-USER G-OPTION-LIB)
(G-SHAPE-CURVE G-SHAPE-RADIAL G-SHAPE-DOTS G-SHAPE-STEPS G-SHAPE-CARTOON G-SHAPE-PATH G-SHAPE-INVERT)
(G-ORIGIN-0 G-ORIGIN-CORNER G-ORIGIN-HALF-X G-ORIGIN-HALF-Y)))
;
; at top-level (not inside a func, nor a let)
;
(eval (do-enum (car *enums*))) ; --> (define ...)
(eval (do-enum (cadr *enums*))) ; --> (define ...)
(eval (do-enum (caddr *enums*)))
;
;---------------------------------------------------
; useful utilities
;---------------------------------------------------
(define (param-message msg . alist) ; must eval to ()
(let* ((ostr (make-string 255)))
(while (term-list? alist) (set! alist (car alist)))
(write alist (open-output-string ostr))
(if (not (string? msg)) (set! msg "XXX"))
(gimp-message (string-trim (string-append msg "\n" ostr)))
) ; let
()) ;; param-message
(define msg param-message)
(define (c256 c) (int (* 255 c))) ; float rgb to rgb
(define (vector->sublist v start end) ; [start ... end [ - assumes start,end valid and end > start
(let* ((l ()))
(while (< start end) (set! l (cons (vector-ref v start) l))
(set! start (+ 1 start)))
(reverse l )))
;---------------------------------------------------------------------------------------
; NOTATIONS CONVENTIONS
;
; E, PI, .. : a constant, user visible
; t,i,.. : a variable, user visible in functions(see *G-vars*)
; *BORDER* : constant, not user visible
; *resolution* ,.. : run-time value, may be modifiable by user, only thru a function : resolution (42)
;
;-----------------------------------------------------------------------------------------
(define *secs* 0)
(define (secs . rest)
(when (pair? rest) (set! *secs* 0) (set! *secs* (secs)))
(- (+ (* (list-ref (time) 3) 3600) (* (list-ref(time) 4) 60) (list-ref(time)5)) *secs*))
(secs 0) ; reset timer at load time
;-----------------------
; MATH'S
;-----------------------
(define EPS 0.0000001)
(define PI (* 4 (atan 1)))
(define *2pi* (* 2 PI)) ; internal (compatibility)
(define 2PI (* 2 PI))
(define E (exp 1))
(define PINORM (sqrt (/ 1 2PI)))
;------------------------------------------------------------------------
; Int (sin(x), 0 ,1) --> (Int (sin x) 0 1) --> (integrate (lambda..) 0 1)
;------------------------------------------------------------------------
(macro (Int form) `(integrate (lambda(x) , (cadr form)) ,@(cddr form)))
(define (adaptive-int f a b eps S fa fb fc depth) ; Integration
(let* (
(c (/ (+ a b) 2))
(h (- b a))
(d (/ (+ a c) 2))
(e (/ (+ c b) 2))
(fd (f d))
(fe (f e))
(Sleft (* (/ h 12) (+ fa (* 4 fd) fc)))
(Sright (* (/ h 12) (+ fc (* 4 fe) fb)))
(S2 (+ Sleft Sright)))
(if (or (<= depth 0) (<= (abs (- S2 S)) (* 15 eps)))
(+ S2 (/ (- S2 S) 15))
(+ ; else
(adaptive-int f a c (/ eps 2) Sleft fa fc fd (- depth 1))
(adaptive-int f c b (/ eps 2) Sright fc fb fe (- depth 1)))
)))
(define (integrate f a b . depth)
(let* (
(c (/ (+ a b) 2))
(h (- b a))
(fa (f a))
(fb (f b))
(fc (f c))
(S (* (/ h 6)(+ fa (* 4 fc) fb)))
(depth (if (null? depth) 10 (car depth))))
(adaptive-int f a b EPS S fa fb fc depth)))
(define (gauss x . sig2)
(let* ((sig2 (if (pair? sig2) (car sig2) 1.0))
(sig2 (/ 1 sig2)))
(* sig2 PINORM (exp (- (* x x 0.5 sig2))))))
(define (normal u) (if (> u 5) 1 (Int (gauss x) -5 (min 5 u))))
;------------------------
; INTEGER MATH
;------------------------
(srand(realtime))
(define (frand . n)
(set! n (if (pair? n) (car n) 1.0))
(* n (/ (- (random 20000) 10000) 10000.))) ;; float in [-n...n]
(define (noise x . w) ; w is noise (%) - default 10%
(if (pair? w) (set! w (car w)) (set! w 10))
(+ x (* (frand x) (/ w 100)))) ;; --> x + w(%)*frand(x)
(define int (lambda (x) (inexact->exact (floor x))))
(define uint (lambda (x) (abs(inexact->exact (floor x)))))
(define (% a b) (modulo (int a) (int b))) ; C-call : a % b
(define mod % ) ;C-call : mod(a,b)
(define (ck-prime p) ; trial division by d > 2
(if (even? p) #f
(let* ((sq (sqrt p)) (d 3) (r #t))
(while (and r (<= d sq))
(if (= (modulo p d) 0)
(set! r #f)
(set! d (+ d 2))))
r ))) ; ck-prime
(define (prime? p) ; simple cases
(let* ((p (uint p)))
(case p
((0 1) #f)
((2 3) #t)
(else
(if (even? p)
#f
(ck-prime p))))))
(define isprime prime?) ; C-like
(define (prime n) ; // next prime > 2
(let* ((n (+ 1 (uint n))))
(if (even? n) (set! n (+ 1 n)))
(while (not (prime? n)) (set! n (+ 2 n)))
n ))
;--------------------------------------------------------
;parameters : get : P(i) set : P(i,value)
;-------------------------------------------------------
(define *P* (make-vector 20 1)) ; p(i) parameters
(define (P i . rest)
(when (pair? rest) (vector-set! *P* i (car rest)))
(vector-ref *P* i))
;----------------------------------------------------------
; counters (adders or multipliers)
;
; usage :
;(count counter-id [add-step | 1=default]) --> 0 , step , step*n , ..
;(mult counter-id [mul-step | 2=default]) --> 1 , step , step^n , ..
; *COUNTERS-NUM* counter are available
;-----------------------------------------------------------
(define *COUNTERS-NUM* 32) ; for user
(define *g-count* (make-vector *COUNTERS-NUM* 0))
(define *g-mult* (make-vector *COUNTERS-NUM* 1))
(define (count-reset-all) (set! *g-count* (make-vector *COUNTERS-NUM* 0)) (set! *g-mult* (make-vector *COUNTERS-NUM* 1)))
(define (count-reset id)
(if (< id *COUNTERS-NUM*) (vector-set! *g-count* id 0)))
(define (mult-reset id)
(if (< id *COUNTERS-NUM*) (vector-set! *g-mult* id 1)))
(define (count id . rest) ; count (i [,step[,init]])
(if (>= id *COUNTERS-NUM*) 0
(let* ((step (if (null? rest) 1 (car rest)))(val 0))
(when (and (pair? rest) (pair? (cdr rest))) (vector-set! *g-count* id (cadr rest)))
(set! val (vector-ref *g-count* id))
(vector-set! *g-count* id (+ val step))
val )))
(define (mult id . rest)
(if (>= id *COUNTERS-NUM*) 1
(let* ((step (if (null? rest) 2 (car rest))) (val 0))
(when (and (pair? rest) (pair? (cdr rest))) (vector-set! *g-mult* id (cadr rest)))
(set! val (vector-ref *g-mult* id))
(vector-set! *g-mult* id (* val step))
val )))
; END OF MATH'S
;----------------------------------
; G->SCHEME FUNCTIONS
;----------------------------------
; (0) G-LANGUAGE
;----------------------------------
(define FILL 1)
(define TRANSPARENT 2)
(define *g-macros* '(if loop when unless animate param )) ; macro here means no comma in G
(define *ops* '((^) (* / %) ( + && || > < = - != ))) ;; ordered priority - two operands
(define *unary* '(- ! ))
(define *special-chars* (string->list "$+-*/%^|&<>={}"))
(define *G-vars* '( $ PI 2PI PINORM E t i a x y .x ..x .y ..y r tmin tmax turn Rx Ry R C Cmax FILL TRANSPARENT)) ; bound when evaluating (r) and (s) and (pgm) - $ is internal
(define *user-funs* '(P origin rotate color glength resolution shape path cartoon stop count mult move sample msg Int xscale yscale gscale verbose))
(define *funs* (append
'(&& || gauss normal round floor ceiling exp expt pow log sin cos tan asin acos atan abs rand sqrt odd even quotient modulo gcd lcm srand min max )
'(int uint frand noise mod prime isprime count mult secs)
*user-funs* ))
(define *no-args-funs* '(stop secs frand))
;-------------------------------
; G functions
;-------------------------------
(define ^ expt) ; #undef if x real < 0 - operator
(define pow expt) ; function
(define (&& a b) (and a b))
(define (|| a b) (or a b))
;--------------------------------
; syntax checker : known symbols
;--------------------------------
(define (g-syntax expr)
(let* (
(names (flatten (append *g-macros* *funs* *ops* *G-vars* *enums*)))
(expr (flatten expr)))
(while (pair? expr)
(if (and (symbol? (car expr)) (not (member (car expr) names)))
(param-message "symbol is unknown : \n" (car expr)))
(set! expr (cdr expr)))))
(define (g-legal-fun? symb)
(or (member symb *g-macros*) (member symb *funs* ) (member symb (flatten *ops*))))
(define (check-calls expr) ; input : not empty list
(if (not (g-legal-fun? (car expr))) ; known fun ?
(param-message "bad function call:\n" (car expr)))
(set! expr (cdr expr))
(while (pair? expr)
(if (pair? (car expr)) (check-calls (car expr)))
(set! expr (cdr expr))))
(define (list-replace! l old new) ; FIRST-LEVEL replace
(while (pair? l)
(if(equal? (car l) old)(set-car! l new))
(set! l (cdr l))) l )
(define (string-replace str old-char new-char) ; old = "\, new = #\$
(let* ((l (string->list str)))
(list-replace! l old-char new-char)
(list->string l)))
(define (list-cut l k)
(if (>= k (length l)) ()
(reverse(list-tail(reverse l) k)))) ; cuts k items- returns a copy
(define (group l) ; ( a + 1 $ b c d $ e f $ g) --> ((a + 1) (b c d) (e f) (g)) - scrambles l -
(if (null? l) ()
(let* ((rest (member '$ l)) (follower ()))
(if (not (pair? rest))
(list l)
(begin
(set! follower (cdr rest))
(set-cdr! rest ()) ; // cut l
(append (list (list-cut l 1)) (group follower)))))))
(define (flatten l) ; ((a b) c (d e ( g h))) --> (a b c d e g h)
(cond
((null? l) ())
((atom? l) l)
((pair? (car l)) (append (flatten (car l)) (flatten (cdr l))))
(#t (append (list (car l)) (flatten (cdr l))))
)); flatten
(define (crunch-list! ls old new) ; ( ... old old ...) --> (... new ...)
(set! ls (member old ls))
(while (pair? ls)
(when (pair? (cdr ls))
(when (equal? (cadr ls) old)
(set-car! ls new)
(set-cdr! ls (cddr ls))))
(set! ls (cdr ls))
(set! ls (member old ls))))
(define (expand-char str char) ; "a+b" --> "a + b" - returns new string
(let* ((ls (string->list str)) (sp ls))
(set! sp (memv char sp))
(while (pair? sp)
(set-car! sp (list #\space (car sp) #\space))
(set! sp (memv char sp))) ; while
; trick "a&&a" --> " a && a " "a&a" -->"a & a" - ZZZZ "! =" --> != NYI
(crunch-list! ls (string->list " | ") (string->list " || "))
(crunch-list! ls (string->list " & ") (string->list " && "))
(list->string (flatten ls))))
;-----------------------------
; (I) INPUT STRING MANIPS
;-----------------------------
(define (string-remove-comment str) ; EVERYTHING after first ';'
(let* ((chars (string->list str)))
(while (member #\; chars) (set! chars (list-cut chars 1)))
(list->string chars)))
(define (string-check-pars str) ; return "0" if failure
(let* ((ls (string->list str)) (c+ 0) (c- 0))
(while (pair? ls)
(if (char=? (car ls) #\( ) (set! c+ (+ 1 c+)))
(if (char=? (car ls) #\) ) (set! c- (+ 1 c-)))
(set! ls (cdr ls)))
(when ( > c+ c-) (msg "too many '(' " str) (set! str "0"))
(when ( < c+ c-) (msg "too many ')' " str) (set! str "0"))
str ))
(define (string->scheme str ops) ; for all ops (chars - insert spaces where needed
(while(pair? ops)
(set! str (expand-char str (car ops)))
(set! ops (cdr ops)))
(if(equal? str "") "0" str)) ; empty string --> 0
;-----------------------------------------------
; ==== (II) CONVERSION : G-SYNTAX --> SCHEME
;------------------------------------------------
(define (term-list? l) (and (pair? l) (= 1 (length l)) ; terminal list like (666)
(not (member (car l) *no-args-funs*))))
(define (flatten-term! l) ; () -->
(if (pair? l)
(begin
(if (term-list? (car l))(set-car! l (caar l)))
(flatten-term! (car l))
(flatten-term! (cdr l))
))) ; flatten
;----------------------------------------------
; infix->prefix
; (... a + c * b ..) --> (... (+ a (* b c)) ...)
;-----------------------------------------------
(define (prefix! l) ; (3 * 4 ...) --> ((* 3 4) ...) ; converts one infix to prefix
(let* ((op (list (cadr l) (car l) (caddr l))))
(set-cdr! l (cdddr l))
(set-car! l op)))
(define (infix->prefix! expr ops) ;; converts infix to prefix for all ops
(if (and
(pair? expr)
(>= (length expr) 3)
(member (cadr expr) ops))
(begin
(unary->prefix! (cddr expr) *unary* #f)
(prefix! expr) ; chirurgy
(infix->prefix! expr ops)
)) ; if-begin
(if(pair? expr)
(begin
(infix->prefix! (car expr) ops)
(infix->prefix! (cdr expr) ops)))
) ; infix->prefix
;------------------------------------
; unary->prefix!
; (... - c ..) --> (... (- c ) ...)
;------------------------------------
(define (unary->prefix! expr ops all) ;; converts unary to prefix for ops
(if (and
(pair? expr)
(= (length expr) 2)
(member (car expr) ops))
(begin
(set-car! expr (list (car expr) (cadr expr)))
(set-cdr! expr (cddr expr))
(set! expr (cdr expr))
)) ; if-begin
(if (and all (pair? expr)) ; all =#t : recurse
(begin
(unary->prefix! (car expr) ops all)
(unary->prefix! (cdr expr) ops all)))
) ; unary->prefix
;------------------------------------------------
; g-macros (language construct - no commas)
; (..if( e1 a b) ..) ..) --> (...(if e1 a b) ..)
;-------------------------------------------------
(define (macro! l)
(set-car! l (cons (car l) (cadr l )))
; (if (not (pair? (cddar l))) (set-car! l (append (car l) '(0)))) ; case (loop 3)
(set-cdr! l (cddr l)))
(define (macro->prefix! expr)
(if (pair? expr)
(begin
(if (member (car expr) *g-macros*)
(begin
(if (null? (cadr expr)) (set-car! (cdr expr) '(1))) ; loop() -> loop(1)
(if (not (pair? (cadr expr))) (param-message "bad macro call at:\n" expr))
(macro! expr);; --> ((if a b c) ...)
(macro->prefix! (cdar expr))
)
(macro->prefix! (car expr))
) ; if member
(macro->prefix! (cdr expr))
))
); macro->prefix!
;------------------------------------------------------------
; funcall
; group params
; ( .. mod ( a $ b) x y ...) --> ( .. (mod (a) (b)) x y ..)
;------------------------------------------------------------
(define (param-list? l) (or (null? l)(pair? l)))
(define-with-return (funcall->prefix! expr)
(if (pair? expr)
(begin
(if (member (car expr) *funs*)
(begin
(if (null? (cdr expr)) (return (param-message "missing arguments in:\n" expr)))
(if (not (param-list? (cadr expr))) (return (param-message "bad function call in:\n" expr)))
(set-car! expr (cons (car expr) (group (cadr expr)))) ; expr ->((mod (a) (b)) x y ..)
(set-cdr! expr (cddr expr))
(funcall->prefix! (cdar expr))
) ; begin : funcall translated
(funcall->prefix! (car expr)) ; else not member
) ; if member
(funcall->prefix! (cdr expr))
)) ; pair?
) ; funcall->prefix!
;----------------------------------------
; (III) G->SCHEME
;----------------------------------------
(define (g->scheme str)
;(print (list "-2 " str))
(let* ((ostr (string-copy str)))
(catch (begin (msg "error in expression" ostr) 1) ; returns 1
(set! str (string-remove-comment str))
(set! str (string-trim str))
;(print (list "-1 " str))
(set! str (string-check-pars str))
(set! str (string-replace str #\, #\$))
;(print (list "0 " str))
(set! str (string-append "(" (string->scheme str *special-chars*) ")"))
;(print (list "I " str))
(set! str (string-replace str #\_ #\-)) ; C_LIKE -> C-LIKE
(let (( (read (open-input-string str))))
;(print (list "Ia " ))
(g-syntax ) ; (throw) could be useful here ...
(macro->prefix! )
;(print (list "II " ))
(funcall->prefix! )
;(print (list "III " ))
(infix->prefix! (car *ops*))
(infix->prefix! (cadr *ops*))
(infix->prefix! (caddr *ops*))
(unary->prefix! *unary* #t)
;(print (list "IIIa " ))
(flatten-term! )
;(print (list "IIIb " ))
(if (pair? (cdr )) (msg "bad expression" ostr))
(if (pair? (car ))(check-calls (car ))) ; known functions ?
;(print (list "IV " ))
(car ))))) ; to be evaluated
; END OF G->SCHEME
;------------------------------------------------------------------------------------
;------------------------------------------------------------------------------------
; THE SCRIPT
;------------------------------------------------------------------------------------
;------------------------------------------------------------------------------------
(define (script-fu-parametric-curves
image drawable lib *color* gradient *glength* brush *resolution* *shape* stmin stmax
ax ay ar sx sy *param-a* *phase* prog )
; caption
(if (or (= image -1) (= drawable -1))
(gimp-message "Please create or load an image\nbefore runnig this script.")
(begin
;----------------------------
; RUN-TIME
;----------------------------
(define *MAX-VDIM* 48000) ;; max number of segments for the pencil = *MAX-VDIM* / 2
;; ||| tiny-scheme bug (make-vector 50000 0.0) hangs ... |||
(define *BORDER* 5)
(define *text-color* '(255 255 255))
(define *text-size* 12)
(define *text-font* "Verdana")
(define (text-caption image drawable x y text )
(let*( (color (car(gimp-context-get-foreground))) (tlayer -1))
(gimp-context-set-foreground *text-color*)
(set! tlayer (car
(gimp-text-fontname image drawable (+ x *BORDER*) (- y *text-size* *text-size* *BORDER*) text 0 TRUE *text-size* PIXELS *text-font*)))
(unless (= tlayer -1) (gimp-floating-sel-anchor tlayer))
(gimp-context-set-foreground color)
))
(define (do-caption param-c title ax ay ar sx sy tmin tmax prog resolution from-lib lib)
(let* ((capt title))
(if (> lib 0)
(set! capt (string-append "\nlib#" (number->string lib) " " capt)))
(set! capt (string-append capt "\n\nresolution:= " (number->string resolution)))
(when param-c
(set! capt (string-append capt "\nx:= " ax))
(set! capt (string-append capt "\ny:= " ay)))
(unless param-c ; polar
(set! capt (string-append capt "\nr:= " ar)))
(set! capt (string-append capt "\nX-scale:= " sx))
(set! capt (string-append capt "\nY-scale:= " sy))
(set! capt (string-append capt "\ntmin:= " (number->string tmin)))
(set! capt (string-append capt "\ntmax:= " (number->string tmax)))
(unless (string=? prog "")
(set! capt (string-append capt "\n\nprogram:= " prog)))
capt))
;-----------
; utilities
;-----------
(macro (++ form) `(set! ,(cadr form) (+ 1 ,(cadr form)))) ; (++ i) -> (set! i (+ 1 i))
; (macro (set form) `(set! ,(cadr form) ,(caddr form)))
;------------------------------------------------
; sx and sy are user provided ( 0 = auto-scale)
;------------------------------------------------
(define (auto-scale segment param-c sx sy Rx Ry gscale verbose)
(let* ((vdim (vector-length segment)) (xmax 0.1)(ymax 0.1)(i 0)(scalex 1)(scaley 1))
(while (< i vdim)
(set! xmax (max xmax (abs (vector-ref segment i))))
(set! ymax (max ymax (abs (vector-ref segment (+ i 1)))))
(set! i (+ 2 i)))
(if(= sx 0) (set! scalex (/ Rx xmax)) (set! scalex (/ Rx sx)))
(if(= sy 0) (set! scaley (/ Ry ymax)) (set! scaley (/ Ry sy)))
(unless param-c (set! scalex scaley)) ; POLAR
(if (> verbose 1) (msg "Scale params" vdim "Rx/y" Rx Ry "x/ymax" xmax ymax "scalex/y" sx sy "screenx/y" scalex scaley "gscale" gscale ))
(if (> verbose 2) (msg "Points" vdim segment))
(set! i 0)
(while (< i vdim)
(vector-set! segment i (* (vector-ref segment i) scalex gscale))
(set! i (+ 1 i))
(vector-set! segment i (* (vector-ref segment i) scaley gscale))
(set! i (+ 1 i)))
)); auto-scale
; -------------------------
; polar inversion z --> 1/z
(define (do-invert segment )
(let* ((vdim (vector-length segment))(x 0)(y 0)(i 0)(r2 0))
(while (< i vdim) ;
(set! x (vector-ref segment i))
(set! y (vector-ref segment (+ 1 i)))
(set! r2 (+ (* x x) (* y y)))
(set! x (if (= r2 0) 0 (/ x r2)))
(set! y (if (= r2 0) 0 (/ y r2)))
(vector-set! segment i x )
(vector-set! segment (+ 1 i) y )
(set! i (+ 2 i)))
)); do-invert
;------------------------ rotation ----------
(define (auto-phase segment phase )
(let* ((vdim (vector-length segment))(x 0)(y 0)(i 0)(r 0)(t 0))
(while (< i vdim) ;
(set! x (vector-ref segment i))
(set! y (vector-ref segment (+ 1 i)))
(set! t (+ phase (atan y x)))
(set! r (sqrt (+ (* x x) (* y y))))
(set! x (* r (cos t)))
(set! y (* r (sin t)))
(vector-set! segment i x )
(vector-set! segment (+ 1 i) y )
(set! i (+ 2 i)))
)); auto-phase
;--------------------------------------------------
(define (steps segment ) ; returns new segment :dim 2*vdim - 2
(let* ((i 0) (j 0) (yi 0.0)
(vdim (vector-length segment))
(sdim (min *MAX-VDIM* (- (* vdim 2) 2)))
(vsteps (make-vector sdim 0.0)))
(while (< i vdim)
(vector-set! vsteps j (vector-ref segment i)) (++ i)(++ j) ;xi
(set! yi (vector-ref segment i))
(vector-set! vsteps j yi) (++ i)(++ j) ;yi
(when (< i vdim)
(vector-set! vsteps j (vector-ref segment i)) (++ j) ;x i+1
(vector-set! vsteps j yi) (++ j)))
vsteps ))
;-------------------------------------
(define (radial segment ) ; return new segment
(let* ((i 0) (j 0) (vdim (vector-length segment)) (vradial #(0.)))
(set! vdim (* 2 vdim))
(if (> vdim *MAX-VDIM*) (set! vdim *MAX-VDIM*))
(set! vradial (make-vector vdim 0.0))
(while (< i (/ vdim 2))
(vector-set! vradial j 0) (set! j (+ 1 j))
(vector-set! vradial j 0) (set! j (+ 1 j))
(vector-set! vradial j (vector-ref segment i)) (set! j (+ 1 j)) (set! i (+ 1 i))
(vector-set! vradial j (vector-ref segment i)) (set! j (+ 1 j)) (set! i (+ 1 i))
) ; while
vradial))
;--------------------------------------
(define (do-move segment dx dy) ; patch segment -
(let* ((i 0) (vdim (vector-length segment)))
(while (< i vdim)
(vector-set! segment i (+ dx (vector-ref segment i)))
(set! i (+ 1 i))
(vector-set! segment i (+ (vector-ref segment i) dy ))
(set! i (+ 1 i)))))
;------------------------------------
(define (xy-to-screen segment width height origin) ; ; 0 = center ; 1 = x>0,y>0 2 = x>0 3= y>0
(let* ((i 0) (vdim (vector-length segment)) (dx 0)(dy 0))
(when(= origin G-ORIGIN-0) (set! dx (/ width 2)) (set! dy (/ height 2)))
(when(= origin G-ORIGIN-CORNER) (set! dx 0) (set! dy height))
(when(= origin G-ORIGIN-HALF-X) (set! dx 0) (set! dy (/ height 2)))
(when(= origin G-ORIGIN-HALF-Y) (set! dx (/ width 2)) (set! dy height))
(while (< i vdim)
(vector-set! segment i (+ dx (vector-ref segment i)))
(set! i (+ 1 i))
(vector-set! segment i (+ dy (-(vector-ref segment i))))
(set! i (+ 1 i)))))
;-------------------------------------
(define (draw-dots drawable segment) ; long .....
(let* ((dot (make-vector 2 0.0)) (i 0) (vdim (vector-length segment)))
(while (< i vdim)
(vector-set! dot 0 (vector-ref segment i))
(set! i (+ 1 i))
(vector-set! dot 1 (vector-ref segment i))
(gimp-pencil drawable 2 dot)
(set! i (+ 1 i))
)))
;-------------------------------------
(define (do-path image segment closed) ; ==> GIMP VECTOR
(let* ((i 2) (path 0)(stroke 0)(vdim (vector-length segment)))
(set! path (car(gimp-vectors-new image "paramoid")))
(gimp-image-add-vectors image path -1)
(set! stroke (car (gimp-vectors-bezier-stroke-new-moveto path (vector-ref segment 0) (vector-ref segment 1))))
;(msg "VECT" vdim path stroke)
(while (< i vdim)
(gimp-vectors-bezier-stroke-lineto path stroke (vector-ref segment i) (vector-ref segment (+ 1 i)))
(set! i (+ 2 i)))
(when closed (gimp-vectors-stroke-close path stroke))
(gimp-image-set-active-vectors image path) ; ???
;; (stroke-fill-path image drawable path stroke scolor fillpath fcolor)
(gimp-vectors-set-visible path TRUE)))
;-------------------------------------
; draw-cartoon : timer to be user settable ZZZZZ
; TIP : low resolution
;-------------------------------------
(define (draw-cartoon drawable segment speed) ; speed = 2 : slower
(secs 0) ; init timer
(gimp-progress-update 0)
(let* ((line (make-vector 4 0.0)) (i 0) (vdim (- (vector-length segment) 2 )))
(while (and (< i vdim) (< (secs) 60))
(vector-set! line 0 (vector-ref segment i)) (set! i (+ 1 i))
(vector-set! line 1 (vector-ref segment i)) (set! i (+ 1 i))
(vector-set! line 2 (vector-ref segment i)) (set! i (+ 1 i))
(vector-set! line 3 (vector-ref segment i))
(gimp-pencil drawable 4 line)
(set! i (- i 1))
(when (= 0 (modulo i speed))(gimp-displays-flush))
(when (= 0 (modulo i 100)) (gimp-progress-update(/ i vdim)))
)))
;------------------------------------------------------------------------
; paramoid : sets xy[] vector := drawing coordinates.
; are available in context for fa1,fa2 (radius) and sa1,sa2 (speed) functions :
; tmin
; tmax
; t in [tmin..tmax]
; x,y
; r
; sx,sy : scaled x,y
; R ,Rx, Ry : max visible f(origin and width,height)
; i = dot index in [0..resolution]
; C = curve number (loops)
; .x,..x .y ..y = x[i-1],..
; a,b,c : parameters set(a ,42)
; phase
;-------------------------------------------------------------------------
(define .x 0) ; x[i-1] for recurrent
(define ..x 0) ; x[i-2]
(define .y 0)
(define ..y 0)
(define (paramoid param-c xy j t fx fy fr tmin tmax Rx Ry R C phase a)
(let* ((x 0) (y 0)(r 0)(i (/ j 2)))
(if param-c (begin
(set! x (eval fx))
(set! y (eval fy))
(set! ..x .x) (set! ..y .y)
(set! .x x) (set! .y y))
; (set! r (sqrt (+ (* x x) (* y y)))) ; in case used in formulae
;else polar
(begin
(set! r (eval fr))
(set! x (* r (cos t)))
(set! y (* r (sin t)))))
(vector-set! xy j x)
(vector-set! xy (+ 1 j) y )
)) ; paramoid
; END UTILITIES
(define *stopped* #f)
(define *prog-env* (make-vector 16 0.0))
(let* (
(new-layer TRUE)
(from-lib (if (= lib 0) 0 1)) ; lib/no lib
(*stopped* #f)
(width (car (gimp-drawable-width drawable)))
(height (car (gimp-drawable-height drawable)))
(x-offset (car (gimp-drawable-offsets drawable)))
(y-offset (cadr (gimp-drawable-offsets drawable)))
(x 0)
(y 0)
(time 0) (dt 0.01)
(segment (make-vector 2 0.0)) ;; (x1 y1 x2 y2 ... )
(vdim 2)
(i 0)
(layer 0)
(ostr (make-string 511)) ;; output buffer
(*loopmax* 1) ;
(*animate* 0 ) ; 1 = FILLed frames, 2 = transparent frames
(*move* '(#f #f)) ; (dx dy)
(*origin* 0) ; 0 = center; 1= up-right quarter ; 2 = half-x 3= half-y
(*phase* (* *2pi* (/ *phase* 360)))
(*tmin* 0) (*tmax* 10)
(Cmax 1)
(dots-number *resolution*)
(Rx 0)(Ry 0)(R 0)
(param-c #t) ; false for polar
(fx (g->scheme ax)) ; may set *stopped* #t
(fy (g->scheme ay))
(fsx (g->scheme sx))
(fsy (g->scheme sy))
(fr (g->scheme ar))
(fprog ())
(title "")
(caption 0) ; call arg
(*speed* 2) ; cartoon speed = #dots / move
(*closed* #f) ; path
(*xscale* #f) (*yscale* #f)
(*gscale* 1) ; global scale
(*verbose* 0)
(prog-lib "") ; Library prog
(fprog-lib ())
)
;; load library items
(if (= from-lib G-OPTION-LIB)
(let* ((plist (lib-get *G-LIBRARY* lib)))
(set! title (list-ref plist 0))
(set! ax (list-ref plist 1)) (set! fx (g->scheme ax))
(set! ay (list-ref plist 2)) (set! fy (g->scheme ay))
(set! ar (list-ref plist 3)) (set! fr (g->scheme ar))
(set! sx (list-ref plist 4)) (set! fsx (g->scheme sx))
(set! sy (list-ref plist 5)) (set! fsy (g->scheme sy))
(set! prog-lib (list-ref plist 6))
(set! stmin (list-ref plist 7))
(set! stmax (list-ref plist 8))
(set! *resolution* (list-ref plist 9)) ;
(set! *origin* (list-ref plist 10))
(set! *shape* (list-ref plist 11)) ;
))
(unless (string=? (string-trim ar) "") (set! param-c #f)) ; polar priority
(set! *tmin* (eval(g->scheme stmin))) ; one time eval
(set! *tmax* (eval(g->scheme stmax)))
(if (= from-lib G-OPTION-LIB)
(gimp-message (do-caption param-c title ax ay ar sx sy *tmin* *tmax* prog *resolution* from-lib lib))) ;
;; ========= save params into gimprc =========
(when (= from-lib G-OPTION-USER)
(write (list ax ay ar sx sy prog stmin stmax *resolution* *origin* *shape* ) (open-output-string ostr))
(set! ostr (string-trim ostr))
(catch 0 (when (not (string=? ostr (car(gimp-gimprc-query "paramoid-1"))))
(catch 0 (gimp-gimprc-set "paramoid-4" (car(gimp-gimprc-query "paramoid-3"))))
(catch 0 (gimp-gimprc-set "paramoid-3" (car(gimp-gimprc-query "paramoid-2"))))
(catch 0 (gimp-gimprc-set "paramoid-2" (car(gimp-gimprc-query "paramoid-1"))))
))
(gimp-gimprc-set "paramoid-1" ostr)
)
;-----------------------------------------------------------------------
; Functions for user prog
; MUST be defined in this context
;-----------------------------------------------------------------------
(define (get-prog-env) (set! *prog-env* (list->vector (list *stopped* *loopmax* "RFU" *phase* *resolution* *color* *animate* *move* *tmin* *tmax* *origin* *shape* *speed* *xscale* *yscale*))))
(define (set-prog-env)
(set! *stopped* (vector-ref *prog-env* 0))
(set! *loopmax* (vector-ref *prog-env* 1))
; (set! RFU (vector-ref *prog-env* 2))
(set! *phase* (vector-ref *prog-env* 3))
(set! *resolution* (vector-ref *prog-env* 4))
(set! *color* (vector-ref *prog-env* 5))
(set! *animate* (vector-ref *prog-env* 6)) ; animation mode
(set! *move* (vector-ref *prog-env* 7))
(set! *tmin* (vector-ref *prog-env* 8))
(set! *tmax* (vector-ref *prog-env* 9))
(set! *origin* (vector-ref *prog-env* 10))
(set! *shape* (vector-ref *prog-env* 11))
(set! *speed* (vector-ref *prog-env* 12))
(set! *xscale* (vector-ref *prog-env* 13))
(set! *yscale* (vector-ref *prog-env* 14)))
(define (stop) (vector-set! *prog-env* 0 #t)) ; rfu
(define (param rest)) ; eval args
(define (loop nloops . rest ) ; set *loopmax* -
(set! Cmax nloops)
(set! *loopmax* nloops)
(vector-set! *prog-env* 1 nloops))
(define (animate nframes animode . rest) ; set *loopmax* - eval rest for side effects
(set! Cmax nframes) ; may be used by 'rest'
(set! *loopmax* nframes)
(vector-set! *prog-env* 1 nframes)
(vector-set! *prog-env* 6 animode)
(set! new-layer TRUE))
; geometry parms
(define (xscale s) (vector-set! *prog-env* 13 s))
(define (yscale s) (vector-set! *prog-env* 14 s))
(define (gscale s) (set! *gscale* s))
(define (rotate p) (vector-set! *prog-env* 3 (* *2pi* (/ p 360))))
(define (resolution r) (vector-set! *prog-env* 4 (uint r)))
(define (move dx dy) (vector-set! *prog-env* 7 (list dx (- dy))))
(define (origin o) (vector-set! *prog-env* 10 o )) ; 0 = center ; 1 = x>0,y>0 2 = x>0 3= y>0
(define (cartoon speed)
(vector-set! *prog-env* 11 G-SHAPE-CARTOON)
(vector-set! *prog-env* 12 (* 2 (int speed))))
(define (shape s) (vector-set! *prog-env* 11 s ))
(define (path attrs)
(vector-set! *prog-env* 11 G-SHAPE-PATH)
(set! *closed* (equal? attrs 1)))
; color parms
(define (color r g b)
(vector-set! *prog-env* 5 (list r g b)))
(define (glength gl)(set! *glength* gl))
(define (sample idx . samples) ; extract idx-th color from gradient
(let* (
(samples (max 2 (if (null? samples) *loopmax* (car samples))))
(idx (modulo (int idx) samples))
(vcolor (cadr (gimp-gradient-get-uniform-samples gradient samples TRUE)))
(rgb (vector->sublist vcolor (* idx 4) (+ 3 (* idx 4))))) ; floating rgb
(vector-set! *prog-env* 5 (map c256 rgb))))
; other params
(define (verbose lvl) (set! *verbose* lvl))
;------------------------------------------------------------
; end user funs
;------------------------------------------------------------
(gimp-context-push)
(gimp-image-undo-group-start image)
(gimp-context-set-foreground *color*)
(gimp-context-set-brush (car brush))
(gimp-context-set-opacity (cadr brush)) ; bogue in spirogimp.scm
(gimp-context-set-paint-mode (cadddr brush))
(gimp-context-set-gradient gradient)
(gimp-selection-none image)
;-----------------------------
; DRAWINGs loop (in same layer)
; looping on C (curve number)
;------------------------------
(set! fprog (g->scheme prog)) ; one time
(set! fprog-lib (g->scheme prog-lib)) ; one time
(do ((C 1 (+ C 1))) ; C is curve# in [1..*loopmax*]
((or *stopped* (> C *loopmax*)))
(get-prog-env) ; *color* ... --> env
(eval fprog-lib) ; library prog
(eval fprog) ; user settings f(C) : (*loopmax*, *phase*,...)
(set-prog-env) ; env --> *color* ...
(if (> *verbose* 0)
(gimp-message (do-caption param-c title ax ay ar sx sy *tmin* *tmax* prog *resolution* from-lib lib))) ;
(when (= new-layer TRUE)
(set! layer (car (gimp-layer-new image width height RGBA-IMAGE "Paramoid" 100.0 NORMAL-MODE)))
(gimp-image-add-layer image layer -1)
(set! drawable layer))
(if (= *animate* FILL) (gimp-drawable-fill drawable BACKGROUND-FILL))
; if transparent remove background ??
(when (= *origin* 0) (set! Rx (/ width 2)) (set! Ry (/ height 2))) ; center is default
(when (= *origin* 1) (set! Rx width) (set! Ry height)) ; x>0 y>0
(when (= *origin* 2) (set! Rx width) (set! Ry (/ height 2))) ; x>0
(when (= *origin* 3) (set! Rx (/ width 2)) (set! Ry height)) ; y>0
(set! R (min Rx Ry))
(gimp-context-set-foreground *color*)
(set! *resolution* (max *resolution* 2)) ; precaution
(set! time *tmin*)
(set! dots-number *resolution*) ;
(set! i 0)
(set! dt (/ (- *tmax* *tmin*) dots-number)) ;;
(set! vdim (+ 2 (* 2 dots-number)))
(set! vdim (min vdim *MAX-VDIM*)) ; tiny-scheme bug
(set! segment (make-vector vdim 0.0))
; (count-reset-all) needs whole session counters
(while (< i vdim) ; build segments vector
(paramoid param-c segment i time fx fy fr *tmin* *tmax* Rx Ry R C *phase* *param-a*)
(set! time (+ time dt))
(set! i (+ 2 i))
) ; end while
;-----------------------
; transformations
;-----------------------
; I) geometry
(if (not (= *phase* 0)) (auto-phase segment *phase* ))
(when (= *shape* G-SHAPE-RADIAL)
(set! segment (radial segment )) ; doubles size
(set! vdim (vector-length segment)))
(when (= *shape* G-SHAPE-STEPS)
(set! segment (steps segment)) ; doubles v size
(set! vdim (vector-length segment)))
(if (= *shape* G-SHAPE-INVERT) (do-invert segment ))
; II) screen coords
(let* ((sx (eval fsx)) (sy (eval fsy)))
(when *xscale* (set! sx *xscale*))
(when *yscale* (set! sy *yscale*))
(auto-scale segment param-c sx sy (- Rx *BORDER*) (- Ry *BORDER*) *gscale* *verbose*))
; true screen coords
(xy-to-screen segment width height *origin*)
(if (car *move*) (do-move segment (car *move*) (cadr *move*))) ; CHECK ME ...
;------------------------
; drawing
;------------------------
(gimp-progress-update(/ (- C 0.5) *loopmax*))
(cond
((= *shape* G-SHAPE-DOTS) (draw-dots drawable segment))
((= *shape* G-SHAPE-CARTOON) (draw-cartoon drawable segment *speed*))
(else
(if (= *glength* 0) ; pencil else paint with gradient
(gimp-pencil drawable vdim segment ) ; actual drawing (only one call to pencil)
(gimp-paintbrush drawable 0 vdim segment PAINT-CONSTANT *glength*)))) ; fade-out=0
(when (= *shape* G-SHAPE-PATH) (do-path image segment *closed* ))
(gimp-progress-update(/ C *loopmax*))
) ; do
; -----------------
; END DO loop
; ------------------
; add caption layer -
; (if (= caption TRUE)
; (text-caption image drawable 0 height (do-caption title ax ay sx sy *tmin* *tmax* "" *resolution* from-lib lib)))
(gimp-displays-flush)
(gimp-image-undo-group-end image)
(gimp-context-pop)) ; let
))); check-image
(script-fu-register "script-fu-parametric-curves"
"Parametric curves..."
"script-fu-parametric-curves ...."
"Georges Brougnard "
"(C) Georges Brougnard - Oct 2010"
"2010-10-19"
""
SF-IMAGE "Input Image" 0
SF-DRAWABLE "Input Drawable" 0
SF-OPTION _"Curve/Library" (map car *G-LIBRARY*)
; SF-TOGGLE _"New Layer" TRUE
SF-COLOR _"Color" '(0 255 0)
SF-GRADIENT _"Gradient" "Yellow Orange"
SF-ADJUSTMENT _"Gradient length (0=none)" (list 0 0 1000 10 100 0 SF-SLIDER)
SF-BRUSH _"Brush" (list "Circle (01)" 100 0 0)
SF-ADJUSTMENT _"Resolution" (list 200 1 20000 50 50 0 SF-SPINNER)
SF-OPTION _"Shape" (list "Curve" "Radial" "Dots" "Steps" "Cartoon" "Path" "Invert(beta)" )
SF-STRING _"tmin " "-PI"
SF-STRING _"tmax " "PI"
SF-STRING "x(t) " "t"
SF-STRING "y(t) " "t*t*t"
SF-STRING "r(t) " ""
SF-STRING _"X-scale (0=auto) " "0"
SF-STRING _"Y-scale (0=auto) " "0"
SF-ADJUSTMENT _"Parameter 'a' " (list 0 0 100 1 1 0 SF-SLIDER)
SF-ADJUSTMENT _"Rotation (deg)" (list 0 -180 180 1 1 0 SF-SLIDER)
; SF-TOGGLE _"Caption" FALSE
SF-TEXT _"program" "param()"
; SF-ADJUSTMENT "VERBOSE" (list 0 0 5 1 1 0 SF-SLIDER)
)
;(script-fu-menu-register "script-fu-parametric-curves" "/GB-scripts")
(script-fu-menu-register "script-fu-parametric-curves" "/Filters/Render")