101 lines
3.0 KiB
Raw Permalink Normal View History

1998-04-10 06:59:06 -04:00
;;;; i m a g e . s t k -- Images functions for STk
1999-02-02 06:13:40 -05:00
;;;; Copyright <20> 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <>
1998-04-10 06:59:06 -04:00
1999-09-05 07:16:41 -04:00
;;;; 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.
1998-04-10 06:59:06 -04:00
;;;; Author: Erick Gallesio []
;;;; Creation date: 15-Oct-1996 14:25
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:52 (eg)
1998-04-10 06:59:06 -04:00
(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))))
(create (lambda (key opt)
(let ((img #f))
(if (null? opt)
;; No option given. Take the key as the file name
1999-09-05 07:16:41 -04:00
;; 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)
(let ((f (string-append (car l) "/" key)))
(set! img (mk-image key (list :file f)))
(unless img (Loop (cdr l))))))))
;; Use option given
1998-04-10 06:59:06 -04:00
(set! img (mk-image key opt)))
(when img
;; Found an image; Register it
(hash-table-put! image-cache key 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
(image 'delete (image-name key))
(hash-table-remove! image-cache key))
(error "free-image: no image with name ~S" key)))))
(provide "image")