path: root/plug-ins/script-fu/scripts/script-fu-compat.init

;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)
    )
  )
)