From: Chris Hanson Date: Tue, 21 Feb 1995 23:11:22 +0000 (+0000) Subject: Several sweeping changes to graphics and image types. Graphics types X-Git-Tag: 20090517-FFI~6618 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b27ac2d71a547ca0cca7ef754a82f66dd25e8796;p=mit-scheme.git Several sweeping changes to graphics and image types. Graphics types now have their names associated with them so that code can dispatch on the name. Each image type is now associated with a particular graphics type, so that it is possible to get the image type given a graphics type. New procedures GRAPHICS-TYPE and IMAGE-TYPE provide very general ways to get pointers to such types. New procedure GRAPHICS-TYPE-NAME gets the name of a graphics type. These changes necessitated some changes in the interface to the graphics type definitions. In particular, there's no longer a procedure to register a graphics type's name, and also the procedure to construct a graphics type now accepts an additional argument, which is the name. --- diff --git a/v7/src/runtime/graphics.scm b/v7/src/runtime/graphics.scm index 7937ea82e..f464f15ef 100644 --- a/v7/src/runtime/graphics.scm +++ b/v7/src/runtime/graphics.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: graphics.scm,v 1.13 1994/11/06 18:06:33 adams Exp $ +$Id: graphics.scm,v 1.14 1995/02/21 23:10:35 cph Exp $ -Copyright (c) 1989-94 Massachusetts Institute of Technology +Copyright (c) 1989-95 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,7 +41,8 @@ MIT in each case. |# (conc-name graphics-device-type/) (constructor %make-graphics-device-type - (operation/available? + (name + operation/available? operation/clear operation/close operation/coordinate-limits @@ -58,7 +59,13 @@ MIT in each case. |# operation/set-coordinate-limits operation/set-drawing-mode operation/set-line-style - custom-operations))) + custom-operations)) + (print-procedure + (standard-unparser-method 'GRAPHICS-TYPE + (lambda (type port) + (write-char #\space port) + (write (graphics-device-type/name type) port))))) + (name false read-only true) (operation/available? false read-only true) (operation/clear false read-only true) (operation/close false read-only true) @@ -76,9 +83,10 @@ MIT in each case. |# (operation/set-coordinate-limits false read-only true) (operation/set-drawing-mode false read-only true) (operation/set-line-style false read-only true) - (custom-operations false read-only true)) + (custom-operations false read-only true) + (properties (make-1d-table) read-only true)) -(define (make-graphics-device-type operations) +(define (make-graphics-device-type name operations) (let ((operations (map (lambda (entry) (if (not (and (pair? entry) @@ -113,24 +121,28 @@ MIT in each case. |# (set-coordinate-limits (operation 'set-coordinate-limits)) (set-drawing-mode (operation 'set-drawing-mode)) (set-line-style (operation 'set-line-style))) - (%make-graphics-device-type available? - clear - close - coordinate-limits - device-coordinate-limits - drag-cursor - draw-line - draw-point - draw-text - flush - move-cursor - open - reset-clip-rectangle - set-clip-rectangle - set-coordinate-limits - set-drawing-mode - set-line-style - operations))))) + (let ((type + (%make-graphics-device-type name + available? + clear + close + coordinate-limits + device-coordinate-limits + drag-cursor + draw-line + draw-point + draw-text + flush + move-cursor + open + reset-clip-rectangle + set-clip-rectangle + set-coordinate-limits + set-drawing-mode + set-line-style + operations))) + (add-graphics-type type) + type))))) (define (graphics-device-type/operation type name) (case name @@ -171,47 +183,66 @@ MIT in each case. |# (cdr entry))))) (define graphics-types '()) -;; alist of ( . ) - -(define (register-graphics-device-type name type) - (set! graphics-types (cons (cons name type) graphics-types)) - unspecific) - -(define (graphics-type-available? type-or-name) - (let loop ((types (%enumerate-graphics-device-types))) - (and (not (null? types)) - (or (eq? type-or-name (caar types)) - (eq? type-or-name (cdar types)) - (loop (cdr types)))))) - -(define (enumerate-graphics-device-types) - (map car (%enumerate-graphics-device-types))) - -(define (%enumerate-graphics-device-types) - (let loop ((items graphics-types) (result '())) - (if (null? items) - (reverse result) - (let ((item (car items))) - (loop (cdr items) - (if ((graphics-device-type/operation/available? (cdr item))) - (cons item result) - result)))))) - -(define (get-default-graphics-device-type) - (let ((types (%enumerate-graphics-device-types))) - (if (null? types) - (error "No graphics device types supported." - 'GET-DEFAULT-GRAPHICS-DEVICE-TYPE)) - (cdar types))) - -(define (lookup-graphics-device-type type-name) - (let ((entry (assq type-name graphics-types))) - (if (not (and entry - ((graphics-device-type/operation/available? (cdr entry))))) - (error "Graphics type not supported:" - type-name - 'LOOKUP-GRAPHICS-DEVICE-TYPE)) - (cdr entry))) + +(define (add-graphics-type type) + (let ((name (graphics-device-type/name type))) + (let loop ((types graphics-types)) + (cond ((null? types) + (set! graphics-types (cons type graphics-types)) + unspecific) + ((eq? name (graphics-device-type/name (car types))) + (set-car! types type)) + (else + (loop (cdr types))))))) + +(define (graphics-type #!optional object error?) + (let ((object (if (default-object? object) #f object)) + (error? (if (default-object? error?) #t error?))) + (let ((test-type + (lambda (type) + (if (graphics-device-type/available? type) + type + (and error? + (error "Graphics type not supported:" type)))))) + (cond ((graphics-device-type? object) + (test-type object)) + ((graphics-device? object) + (test-type (graphics-device/type object))) + ((not object) + (or (list-search-positive graphics-types + graphics-device-type/available?) + (and error? + (error "No graphics types supported.")))) + (else + (let ((type + (list-search-positive graphics-types + (lambda (type) + (eq? object (graphics-device-type/name type)))))) + (if type + (test-type type) + (and error? + (error "Graphics type unknown:" object))))))))) + +(define graphics-type-available? + graphics-type) + +(define (enumerate-graphics-types) + (list-transform-positive graphics-types graphics-device-type/available?)) + +(define (graphics-device-type/available? type) + ((graphics-device-type/operation/available? type))) + +(define (graphics-type-name type) + (guarantee-graphics-type type 'GRAPHICS-TYPE-NAME) + (graphics-device-type/name type)) + +(define (graphics-type-properties type) + (guarantee-graphics-type type 'GRAPHICS-TYPE-PROPERTIES) + (graphics-device-type/properties type)) + +(define (guarantee-graphics-type type name) + (if (not (graphics-device-type? type)) + (error:wrong-type-argument type "graphics type" name))) (define-structure (graphics-device (conc-name graphics-device/) @@ -225,12 +256,7 @@ MIT in each case. |# (define (make-graphics-device #!optional type-name . arguments) (let ((type - (cond ((or (default-object? type-name) (not type-name)) - (get-default-graphics-device-type)) - ((graphics-device-type? type-name) - type-name) - (else - (lookup-graphics-device-type type-name))))) + (graphics-type (if (default-object? type-name) #f type-name)))) (apply (graphics-device-type/operation/open type) (lambda (descriptor) (and descriptor @@ -378,8 +404,10 @@ MIT in each case. |# ;;; rectangular images that can be copied from and into the graphics ;;; device -(define-structure (image-type (conc-name image-type/) - (constructor %make-image-type)) +(define-structure (image-device-type + (conc-name image-type/) + (constructor %make-image-type) + (predicate image-type?)) (operation/create false read-only true) (operation/destroy false read-only true) (operation/width false read-only true) @@ -388,6 +416,20 @@ MIT in each case. |# (operation/draw-subimage false read-only true) (operation/fill-from-byte-vector false read-only true)) +(define (image-type #!optional object error?) + (let ((object (if (default-object? object) #f object)) + (error? (if (default-object? error?) #t error?))) + (if (image-type? object) + object + (let ((type (graphics-type object error?))) + (and type + (or (1d-table/get (graphics-type-properties type) + 'IMAGE-TYPE + #f) + (and error? + (error "Graphics type has no associated image type:" + type)))))))) + (define (make-image-type operations) (let ((operations (map (lambda (entry) diff --git a/v7/src/runtime/starbase.scm b/v7/src/runtime/starbase.scm index 7b61fdb20..475176910 100644 --- a/v7/src/runtime/starbase.scm +++ b/v7/src/runtime/starbase.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/starbase.scm,v 1.11 1994/11/06 18:06:22 adams Exp $ +$Id: starbase.scm,v 1.12 1995/02/21 23:10:48 cph Exp $ -Copyright (c) 1989-92 Massachusetts Institute of Technology +Copyright (c) 1989-95 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -65,6 +65,7 @@ MIT in each case. |# (define (initialize-package!) (set! starbase-graphics-device-type (make-graphics-device-type + 'STARBASE `((available? ,operation/available?) (clear ,operation/clear) (close ,operation/close) @@ -94,7 +95,6 @@ MIT in each case. |# (text-rotation ,operation/text-rotation) (text-slant ,operation/text-slant) (write-image-file ,operation/write-image-file)))) - (register-graphics-device-type 'starbase starbase-graphics-device-type) unspecific) (define starbase-graphics-device-type) diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm index 4973d3060..933ee30ee 100644 --- a/v7/src/runtime/x11graph.scm +++ b/v7/src/runtime/x11graph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: x11graph.scm,v 1.40 1995/01/06 00:49:43 cph Exp $ +$Id: x11graph.scm,v 1.41 1995/02/21 23:11:22 cph Exp $ Copyright (c) 1989-95 Massachusetts Institute of Technology @@ -209,6 +209,7 @@ MIT in each case. |# (define (initialize-package!) (set! x-graphics-device-type (make-graphics-device-type + 'X `((available? ,x-graphics/available?) (clear ,x-graphics/clear) (close ,x-graphics/close-window) @@ -259,8 +260,6 @@ MIT in each case. |# (set-window-name ,x-graphics/set-window-name) (starbase-filename ,x-graphics/starbase-filename) (withdraw-window ,x-graphics/withdraw-window)))) - (register-graphics-device-type 'X x-graphics-device-type) -; (register-graphics-device 'X11 x-graphics-device-type) (set! display-list (make-protection-list)) (add-gc-daemon! close-lost-displays-daemon) (add-event-receiver! event:after-restore drop-all-displays) @@ -837,9 +836,7 @@ MIT in each case. |# ;; X-IMAGE is the descriptor of the generic images. -(define-structure - (x-image - (conc-name x-image/)) +(define-structure (x-image (conc-name x-image/)) descriptor window width @@ -847,21 +844,18 @@ MIT in each case. |# (define image-list) -;; This is the generic image interface to X-IMAGES: - -(define x-graphics-image-type) - (define (initialize-image-datatype) - (set! x-graphics-image-type - (make-image-type - `((create ,create-x-image) ;;this one returns an IMAGE descriptor - (destroy ,x-graphics-image/destroy) - (width ,x-graphics-image/width) - (height ,x-graphics-image/height) - (draw ,x-graphics-image/draw) - (draw-subimage ,x-graphics-image/draw-subimage) - (fill-from-byte-vector ,x-graphics-image/fill-from-byte-vector)))) - + (1d-table/put! + (graphics-type-properties x-graphics-device-type) + 'IMAGE-TYPE + (make-image-type + `((create ,create-x-image) ;;this one returns an IMAGE descriptor + (destroy ,x-graphics-image/destroy) + (width ,x-graphics-image/width) + (height ,x-graphics-image/height) + (draw ,x-graphics-image/draw) + (draw-subimage ,x-graphics-image/draw-subimage) + (fill-from-byte-vector ,x-graphics-image/fill-from-byte-vector)))) (set! image-list (make-protection-list)) (add-gc-daemon! destroy-lost-images-daemon)) @@ -901,7 +895,7 @@ MIT in each case. |# ;; Abstraction layer for generic images (define (x-graphics/create-image device width height) - (image/create x-graphics-image-type device width height)) + (image/create (image-type device) device width height)) ;;(define x-graphics-image/create create-x-image)