101 lines
3.0 KiB
Plaintext
101 lines
3.0 KiB
Plaintext
;;;;
|
|
;;;; i m a g e . s t k -- Images functions for STk
|
|
;;;;
|
|
;;;; Copyright © 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 15-Oct-1996 14:25
|
|
;;;; Last file update: 3-Sep-1999 19:52 (eg)
|
|
|
|
(require "hash")
|
|
|
|
(select-module Tk)
|
|
|
|
(define find-image #f)
|
|
(define make-image #f)
|
|
(define change-image #f)
|
|
(define delete-image #f)
|
|
|
|
;;
|
|
;; Images are cached in a local cache variable. Each image is given a key
|
|
;; so that multple use of the same image share the same copy
|
|
;;
|
|
|
|
(let* ((image-cache (make-hash-table string=?))
|
|
(image-name (lambda (key) (& "*Img " key "*")))
|
|
(mk-image (lambda (name opt)
|
|
(let ((img #f)
|
|
(name (image-name name))) ; to avoid breaking globals
|
|
;; Try to create a bitmap then a pixmap else a photo image.
|
|
(and (catch (set! img (apply image 'cre 'bitmap name opt)))
|
|
(catch (set! img (apply image 'cre 'pixmap name opt)))
|
|
(catch (set! img (apply image 'cre 'photo name opt))))
|
|
img)))
|
|
(create (lambda (key opt)
|
|
(let ((img #f))
|
|
(if (null? opt)
|
|
;; No option given. Take the key as the file name
|
|
(begin
|
|
;; First try without prefix
|
|
(set! img (mk-image key
|
|
(list :file
|
|
(expand-file-name key))))
|
|
(unless img
|
|
;; File without prefix was not an image. Try to
|
|
;; prepend paths of *image-path* to it
|
|
(let loop ((l *image-path*))
|
|
(if (null? l)
|
|
#f
|
|
(let ((f (string-append (car l) "/" key)))
|
|
(set! img (mk-image key (list :file f)))
|
|
(unless img (Loop (cdr l))))))))
|
|
;; Use option given
|
|
(set! img (mk-image key opt)))
|
|
(when img
|
|
;; Found an image; Register it
|
|
(hash-table-put! image-cache key img))
|
|
img))))
|
|
;;
|
|
;; make-image
|
|
;;
|
|
(set! make-image (lambda (key . opt)
|
|
(or (find-image key) (create key opt))))
|
|
|
|
;;
|
|
;; find-image
|
|
;;
|
|
(set! find-image (lambda (key)
|
|
(hash-table-get image-cache key #f)))
|
|
|
|
;;
|
|
;; change-image
|
|
;;
|
|
(set! change-image (lambda (key . opt)
|
|
(let ((img (find-image key)))
|
|
(if img
|
|
(create key opt)
|
|
(error "change-image: no image with name ~S" key)))))
|
|
;;
|
|
;; delete-image
|
|
;;
|
|
(set! delete-image (lambda (key)
|
|
(let ((img (find-image key)))
|
|
(if img
|
|
(begin
|
|
(image 'delete (image-name key))
|
|
(hash-table-remove! image-cache key))
|
|
(error "free-image: no image with name ~S" key)))))
|
|
|
|
)
|
|
|
|
(provide "image")
|