;;;; ;;;; I m a g e . s t k l o s -- The Tk4.0 image mechanism ;;;; ;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; Permission to use, copy, and/or distribute this software and its ;;;; documentation for any purpose and without fee is hereby granted, provided ;;;; that both the above copyright notice and this permission notice appear in ;;;; all copies and derived works. Fees for distribution or use of this ;;;; software or derived works may only be charged with express written ;;;; permission of the copyright holder. ;;;; This software is provided ``as is'' without express or implied warranty. ;;;; ;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Creation date: 26-Jul-1995 11:23 ;;;; Last file update: 21-Mar-1998 22:38 (require "Basics") (require "image") ; The one with a lower "i" (select-module STklos+Tk) ;;;; Images can be seen in two ways in STklos, depending of what you ;;;; want to do with them. If you want just to load an image in a ;;;; button or a label without modifying its parameters (gamma ;;;; correction, palette, ..) you can use the class . This ;;;; class uses the make-image helper function which knows about the ;;;; *image-path* variable. To create such an image can be done with ;;;; (make "teapot.ppm") ;;;; ;;;; On the other hand, if you want to deal with images options you ;;;; have to take the appropriate class depending of the type of image ;;;; you want to manipulate. The available classes for that are ;;;; , , , ... ;;;; Here is how the hierarchy is organized ;;;; common ancestor ;;;; simple to use images (format independant) ;;;; Basic class for "complex" image manipulation ;;;; Bitmaps and all its options ;;;; GIF and PPM and all their options ;;;; ..... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () ((Id :getter Id) (image-type :getter image-type :allocation :virtual :slot-ref (lambda(o) (image 'type (Id o))) :slot-set! (lambda(o v) (Tk:slot-is-read-only o 'image-type))) (width :getter width :allocation :virtual :slot-ref (lambda(o) (image 'width (Id o))) :slot-set! (lambda(o v) (Tk:slot-is-read-only o 'width))) (height :getter height :allocation :virtual :slot-ref (lambda(o) (image 'height (Id o))) :slot-set! (lambda(o v) (Tk:slot-is-read-only o 'height)))) :metaclass ) ;;; ;;; Write-object ;;; (define-method Tk-write-object((self ) port) (display (widget-name (slot-ref self 'id)) port)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () ((file :initform #f :init-keyword :file))) (define-method initialize ((self ) initargs) (next-method) (let ((file (slot-ref self 'file))) (unless file (error " initialization requires a file name")) (let ((Id (make-image file))) (if Id (slot-set! self 'Id Id) (error "Cannot create image with file ~S" file))))) ;;; ;;; Destroy ;;; (define-method destroy ((self )) (delete-image (slo-ref self 'Id))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () ((file :accessor file :init-keyword :file :allocation :tk-virtual) (data :accessor image-data :init-keyword :data :allocation :tk-virtual))) (define-method initialize ((self ) initargs) (let ((tk-options (get-keyword :tk-options initargs '()))) (slot-set! self 'id (initialize-image self tk-options)) (next-method))) ;;; ;;; Destroy ;;; (define-method destroy ((self )) (image 'delete self)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () ((background :accessor background :init-keyword :background :allocation :tk-virtual) (foreground :accessor foreground :init-keyword :foreground :allocation :tk-virtual) (mask-data :accessor mask-data :init-keyword :mask-data :tk-name maskdata :allocation :tk-virtual) (mask-file :accessor mask-file :init-keyword :mask-file :tk-name maskfile :allocation :tk-virtual))) (define-method initialize-image((self ) args) (apply image 'create 'bitmap (gensym "Img ") args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () ((channel :accessor channel :init-keyword :channel :allocation :tk-virtual) (image-format :accessor image-format :init-keyword :image-format :tk-name format :allocation :tk-virtual) (gamma :accessor gamma :init-keyword :gamma :allocation :tk-virtual) (height :accessor height :init-keyword :height :allocation :tk-virtual) (palette :accessor palette :init-keyword :palette :allocation :tk-virtual) (width :accessor width :init-keyword :width :allocation :tk-virtual))) (define-method initialize-image((self ) args) (apply image 'create 'photo (gensym "Img ") args)) ;;; [FIXME] functions for photo images should be written here. But is is ;;; really necessary ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () ()) (define-method initialize-image((self ) args) (require "pixmap") (apply image 'create 'pixmap (gensym "Img ") args)) (provide "Image")