diff options
Diffstat (limited to 'plug-ins/script-fu/scripts/script-fu-compat.init')
| -rw-r--r-- | plug-ins/script-fu/scripts/script-fu-compat.init | 457 |
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) + ) + ) +) |