50 lines
1.3 KiB
Plaintext
50 lines
1.3 KiB
Plaintext
;; C'est très laid. puisque ca peremt de définir une globale et donc de
|
|
;; truander les controles d'accès.
|
|
;; (scale '.s :variable 'speed)
|
|
;; (.s 'set 1)
|
|
;; (destroy .s)
|
|
|
|
(require "image")
|
|
|
|
(define (make-animation pattern parent delay)
|
|
(let* ((files (sort (glob pattern) string<?))
|
|
(size (length files))
|
|
(images (make-vector size))
|
|
(name (gensym (& (if (eq? parent *root*) "" parent) ".l")))
|
|
(widget (label name :bd 0 :relief "flat" :background "white"
|
|
:env (the-environment))))
|
|
;; Store in the image vector all the components of the animation
|
|
(dotimes (i size)
|
|
(let ((key (list-ref files i)))
|
|
(vector-set! images
|
|
i
|
|
(make-image key :file key))))
|
|
|
|
;; Display the first image of the animation
|
|
(tk-set! widget :image (vector-ref images 0))
|
|
|
|
;; Animate the image
|
|
(letrec ((anim (let ((i 0))
|
|
(lambda ()
|
|
(when (winfo (quote exists) widget)
|
|
(when (>= i size)
|
|
(set! i 0))
|
|
(tk-set! widget :image (vector-ref images i))
|
|
(set! i (+ i 1))
|
|
(update)
|
|
(after delay anim))))))
|
|
(after 'idle anim))
|
|
widget))
|
|
|
|
|
|
(define (change-animation-delay w delay)
|
|
(let ((env (tk-get w :env)))
|
|
(eval `(set! delay ,delay) env)))
|
|
|
|
|
|
(define x (make-animation "/users/eg/PublicHtml/img*.gif" *root* 100))
|
|
(pack x :fill "both" :expand #t)
|
|
|
|
(change-animation-delay x 1000)
|
|
|