summaryrefslogtreecommitdiffstats
path: root/plug-ins/script-fu/scripts/script-fu-compat.init
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--plug-ins/script-fu/scripts/script-fu-compat.init457
1 files changed, 457 insertions, 0 deletions
diff --git a/plug-ins/script-fu/scripts/script-fu-compat.init b/plug-ins/script-fu/scripts/script-fu-compat.init
new file mode 100644
index 0000000..865cf80
--- /dev/null
+++ b/plug-ins/script-fu/scripts/script-fu-compat.init
@@ -0,0 +1,457 @@
+;The Scheme code in this file provides some compatibility with scripts that
+;were originally written for use with the older SIOD based Script-Fu plug-in
+;of GIMP.
+;
+;All items defined in this file except for the random number routines are
+;deprecated. Existing scripts should be updated to avoid the use of the
+;compatibility functions and define statements which follow the random number
+;generator routines.
+;
+;The items marked as deprecated at the end of this file may be removed
+;at some later date.
+
+
+;The random number generator routines below have been slightly reformatted.
+;A couple of define blocks which are not needed have been commented out.
+;It has also been extended to enable it to generate numbers with exactly 31
+;bits or more.
+;The original file was called rand2.scm and can be found in:
+;http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/math/random/
+
+; Minimal Standard Random Number Generator
+; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
+; better constants, as proposed by Park.
+; By Ozan Yigit
+
+;(define *seed* 1)
+
+(define (srand seed)
+ (set! *seed* seed)
+ *seed*
+)
+
+(define (msrg-rand)
+ (let (
+ (A 48271)
+ (M 2147483647)
+ (Q 44488)
+ (R 3399)
+ )
+ (let* (
+ (hi (quotient *seed* Q))
+ (lo (modulo *seed* Q))
+ (test (- (* A lo) (* R hi)))
+ )
+ (if (> test 0)
+ (set! *seed* test)
+ (set! *seed* (+ test M))
+ )
+ )
+ )
+ *seed*
+)
+
+; poker test
+; seed 1
+; cards 0-9 inclusive (random 10)
+; five cards per hand
+; 10000 hands
+;
+; Poker Hand Example Probability Calculated
+; 5 of a kind (aaaaa) 0.0001 0
+; 4 of a kind (aaaab) 0.0045 0.0053
+; Full house (aaabb) 0.009 0.0093
+; 3 of a kind (aaabc) 0.072 0.0682
+; two pairs (aabbc) 0.108 0.1104
+; Pair (aabcd) 0.504 0.501
+; Bust (abcde) 0.3024 0.3058
+
+(define (random n)
+ (define (internal-random n)
+ (let* (
+ (n (inexact->exact (truncate n)))
+ (M 2147483647)
+ (slop (modulo M (abs n)))
+ )
+ (let loop ((r (msrg-rand)))
+ (if (>= r slop)
+ (modulo r n)
+ (loop (msrg-rand))
+ )
+ )
+ )
+ )
+
+ ; Negative numbers have a bigger range in twos complement platforms
+ ; (nearly all platforms out there) than positive ones, so we deal with
+ ; the numbers in negative form.
+ (if (> n 0)
+ (+ n (random (- n)))
+
+ (if (>= n -2147483647)
+ (internal-random n)
+
+ ; 31-or-more-bits number requested - needs multiple extractions
+ ; because we don't generate enough random bits.
+ (if (>= n -1152921504606846975)
+ ; Up to 2^60-1, two extractions are enough
+ (let ((q (- (quotient (+ n 1) 1073741824) 1))) ; q=floor(n/2^30)
+ (let loop ()
+ (let ((big (+ (* (internal-random q) 1073741824)
+ (internal-random -1073741824)
+ )
+ ))
+ (if (> big n)
+ big
+ (loop)
+ )
+ )
+ )
+ )
+
+ ; From 2^60 up, we do three extractions.
+ ; The code is better understood if seen as generating three
+ ; digits in base 2^30. q is the maximum value the first digit
+ ; can take. The other digits can take the full range.
+ ;
+ ; The strategy is to generate a random number digit by digit.
+ ; Here's an example in base 10. Say the input n is 348
+ ; (thus requesting a number between 0 and 347). Then the algorithm
+ ; first calls (internal-random 4) to get a digit between 0 and 3,
+ ; then (internal-random 10) twice to get two more digits between
+ ; 0 and 9. Say the result is 366: since it is greater than 347,
+ ; it's discarded and the process restarted. When the result is
+ ; <= 347, that's the returned value. The probability of it being
+ ; greater than the max is always strictly less than 1/2.
+ ;
+ ; This is the same idea but in base 2^30 (1073741824). The
+ ; first digit's weight is (2^30)^2 = 1152921504606846976,
+ ; similarly to how in our base 10 example, the first digit's
+ ; weight is 10^2 = 100. In the base 10 example we first divide
+ ; the target number 348 by 100, taking the ceiling, to get 4.
+ ; Here we divide by (2^30)^2 instead, taking the ceiling too.
+ ;
+ ; The math is a bit obscured by the fact that we generate
+ ; the digits as negative, so that the result is negative as
+ ; well, but it's really the same thing. Changing the sign of
+ ; every digit just changes the sign of the result.
+ ;
+ ; This method works for n up to (2^30)^2*(2^31-1) which is
+ ; 2475880077417839045191401472 (slightly under 91 bits). That
+ ; covers the 64-bit range comfortably, and some more. If larger
+ ; numbers are needed, they'll have to be composed with a
+ ; user-defined procedure.
+
+ (if (>= n -2475880077417839045191401472)
+ (let ((q (- (quotient (+ n 1) 1152921504606846976) 1))) ; q=floor(n/2^60)
+ (let loop ()
+ (let ((big (+ (* (internal-random q) 1152921504606846976)
+ (* (internal-random -1073741824) 1073741824)
+ (internal-random -1073741824)
+ )
+ ))
+ (if (> big n)
+ big
+ (loop)
+ )
+ )
+ )
+ )
+ (error "requested (random n) range too large")
+ )
+ )
+ )
+ )
+)
+
+;(define (rngtest)
+; (display "implementation ")
+; (srand 1)
+; (do
+; ( (n 0 (+ n 1)) )
+; ( (>= n 10000) )
+; (msrg-rand)
+; )
+; (if (= *seed* 399268537)
+; (display "looks correct.")
+; (begin
+; (display "failed.")
+; (newline)
+; (display " current seed ") (display *seed*)
+; (newline)
+; (display " correct seed 399268537")
+; )
+; )
+; (newline)
+;)
+
+
+;This macro defines a while loop which is needed by some older scripts.
+;This is here since it is not defined in R5RS and could be handy to have.
+
+;This while macro was found at:
+;http://www.aracnet.com/~briand/scheme_eval.html
+(define-macro (while test . body)
+ `(let loop ()
+ (cond
+ (,test
+ ,@body
+ (loop)
+ )
+ )
+ )
+)
+
+
+;The following define block(s) require the tsx extension to be loaded
+
+(define (realtime)
+ (car (gettimeofday))
+)
+
+
+;Items below this line are for compatibility with Script-Fu but
+;may be useful enough to keep around
+
+(define (delq item lis)
+ (let ((l '()))
+ (unless (null? lis)
+ (while (pair? lis)
+ (if (<> item (car lis))
+ (set! l (append l (list (car lis))))
+ )
+ (set! lis (cdr lis))
+ )
+ )
+
+ l
+ )
+)
+
+(define (make-list count fill)
+ (vector->list (make-vector count fill))
+)
+
+(define (strbreakup str sep)
+ (let* (
+ (seplen (string-length sep))
+ (start 0)
+ (end (string-length str))
+ (i start)
+ (l '())
+ )
+
+ (if (= seplen 0)
+ (set! l (list str))
+ (begin
+ (while (<= i (- end seplen))
+ (if (substring-equal? sep str i (+ i seplen))
+ (begin
+ (if (= start 0)
+ (set! l (list (substring str start i)))
+ (set! l (append l (list (substring str start i))))
+ )
+ (set! start (+ i seplen))
+ (set! i (+ i seplen -1))
+ )
+ )
+
+ (set! i (+ i 1))
+ )
+
+ (set! l (append l (list (substring str start end))))
+ )
+ )
+
+ l
+ )
+)
+
+(define (string-downcase str)
+ (list->string (map char-downcase (string->list str)))
+)
+
+(define (string-trim str)
+ (string-trim-right (string-trim-left str))
+)
+
+(define (string-trim-left str)
+ (let (
+ (strlen (string-length str))
+ (i 0)
+ )
+
+ (while (and (< i strlen)
+ (char-whitespace? (string-ref str i))
+ )
+ (set! i (+ i 1))
+ )
+
+ (substring str i (string-length str))
+ )
+)
+
+(define (string-trim-right str)
+ (let ((i (- (string-length str) 1)))
+
+ (while (and (>= i 0)
+ (char-whitespace? (string-ref str i))
+ )
+ (set! i (- i 1))
+ )
+
+ (substring str 0 (+ i 1))
+ )
+)
+
+(define (string-upcase str)
+ (list->string (map char-upcase (string->list str)))
+)
+
+(define (substring-equal? str str2 start end)
+ (string=? str (substring str2 start end))
+)
+
+(define (unbreakupstr stringlist sep)
+ (let ((str (car stringlist)))
+
+ (set! stringlist (cdr stringlist))
+ (while (not (null? stringlist))
+ (set! str (string-append str sep (car stringlist)))
+ (set! stringlist (cdr stringlist))
+ )
+
+ str
+ )
+)
+
+
+;Items below this line are deprecated and should not be used in new scripts.
+
+(define aset vector-set!)
+(define aref vector-ref)
+(define fopen open-input-file)
+(define mapcar map)
+(define nil '())
+(define nreverse reverse)
+(define pow expt)
+(define prin1 write)
+
+(define (print obj . port)
+ (apply write obj port)
+ (newline)
+)
+
+(define strcat string-append)
+(define string-lessp string<?)
+(define symbol-bound? defined?)
+(define the-environment current-environment)
+
+(define *pi*
+ (* 4 (atan 1.0))
+)
+
+(define (butlast x)
+ (if (= (length x) 1)
+ '()
+ (reverse (cdr (reverse x)))
+ )
+)
+
+(define (cons-array count type)
+ (case type
+ ((long) (make-vector count 0))
+ ((short) (make-vector count 0))
+ ((byte) (make-vector count 0))
+ ((double) (make-vector count 0.0))
+ ((string) (vector->list (make-vector count "")))
+ (else type)
+ )
+)
+
+(define (fmod a b)
+ (- a (* (truncate (/ a b)) b))
+)
+
+(define (fread arg1 file)
+
+ (define (fread-get-chars count file)
+ (let (
+ (str "")
+ (c 0)
+ )
+
+ (while (> count 0)
+ (set! count (- count 1))
+ (set! c (read-char file))
+ (if (eof-object? c)
+ (set! count 0)
+ (set! str (string-append str (make-string 1 c)))
+ )
+ )
+
+ (if (eof-object? c)
+ ()
+ str
+ )
+ )
+ )
+
+ (if (number? arg1)
+ (begin
+ (set! arg1 (inexact->exact (truncate arg1)))
+ (fread-get-chars arg1 file)
+ )
+ (begin
+ (set! arg1 (fread-get-chars (string-length arg1) file))
+ (string-length arg1)
+ )
+ )
+)
+
+(define (last x)
+ (cons (car (reverse x)) '())
+)
+
+(define (nth k list)
+ (list-ref list k)
+)
+
+(define (prog1 form1 . form2)
+ (let ((a form1))
+ (if (not (null? form2))
+ form2
+ )
+ a
+ )
+)
+
+(define (rand . modulus)
+ (if (null? modulus)
+ (msrg-rand)
+ (apply random modulus)
+ )
+)
+
+(define (strcmp str1 str2)
+ (if (string<? str1 str2)
+ -1
+ (if (string>? str1 str2)
+ 1
+ 0
+ )
+ )
+)
+
+(define (trunc n)
+ (inexact->exact (truncate n))
+)
+
+(define verbose
+ (lambda n
+ (if (or (null? n) (not (number? (car n))))
+ 0
+ (car n)
+ )
+ )
+)