From 00e2bd767f00edcba1a2f98b70e4ff2a99d4f83a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 23 Jun 1989 00:01:43 +0000 Subject: [PATCH] Initial revision --- v7/src/runtime/graphics.scm | 343 ++++++++++++++++++++++++++++++++++++ v7/src/runtime/starbase.scm | 232 ++++++++++++++++++++++++ v7/src/runtime/x11graph.scm | 175 ++++++++++++++++++ 3 files changed, 750 insertions(+) create mode 100644 v7/src/runtime/graphics.scm create mode 100644 v7/src/runtime/starbase.scm create mode 100644 v7/src/runtime/x11graph.scm diff --git a/v7/src/runtime/graphics.scm b/v7/src/runtime/graphics.scm new file mode 100644 index 000000000..592c92af9 --- /dev/null +++ b/v7/src/runtime/graphics.scm @@ -0,0 +1,343 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/graphics.scm,v 1.1 1989/06/23 00:01:08 cph Exp $ + +Copyright (c) 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Graphics Operations +;;; package: (runtime graphics) + +(declare (usual-integrations)) + +(define-structure (graphics-device-type + (conc-name graphics-device-type/) + (constructor + %make-graphics-device-type + (operation/available? + operation/clear + operation/close + operation/coordinate-limits + operation/device-coordinate-limits + operation/drag-cursor + operation/draw-line + operation/draw-point + operation/draw-text + operation/flush + operation/move-cursor + operation/open + operation/reset-clip-rectangle + operation/set-clip-rectangle + operation/set-coordinate-limits + operation/set-drawing-mode + operation/set-line-style + custom-operations))) + (operation/available? false read-only true) + (operation/clear false read-only true) + (operation/close false read-only true) + (operation/coordinate-limits false read-only true) + (operation/device-coordinate-limits false read-only true) + (operation/drag-cursor false read-only true) + (operation/draw-line false read-only true) + (operation/draw-point false read-only true) + (operation/draw-text false read-only true) + (operation/flush false read-only true) + (operation/move-cursor false read-only true) + (operation/open false read-only true) + (operation/reset-clip-rectangle false read-only true) + (operation/set-clip-rectangle false read-only true) + (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)) + +(define (make-graphics-device-type operations) + (let ((operations + (map (lambda (entry) + (if (not (and (pair? entry) + (symbol? (car entry)) + (pair? (cdr entry)) + (procedure? (cadr entry)) + (null? (cddr entry)))) + (error "Malformed operation alist entry" entry)) + (cons (car entry) (cadr entry))) + operations))) + (let ((operation + (lambda (name) + (let ((entry (assq name operations))) + (if (not entry) + (error "Missing operation" name)) + (set! operations (delq! entry operations)) + (cdr entry))))) + (let ((available? (operation 'available?)) + (clear (operation 'clear)) + (close (operation 'close)) + (coordinate-limits (operation 'coordinate-limits)) + (device-coordinate-limits (operation 'device-coordinate-limits)) + (drag-cursor (operation 'drag-cursor)) + (draw-line (operation 'draw-line)) + (draw-point (operation 'draw-point)) + (draw-text (operation 'draw-text)) + (flush (operation 'flush)) + (move-cursor (operation 'move-cursor)) + (open (operation 'open)) + (reset-clip-rectangle (operation 'reset-clip-rectangle)) + (set-clip-rectangle (operation 'set-clip-rectangle)) + (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))))) + +(define (graphics-device-type/operation type name) + (case name + ((clear) + (graphics-device-type/operation/clear type)) + ((close) + (graphics-device-type/operation/close type)) + ((coordinate-limits) + (graphics-device-type/operation/coordinate-limits type)) + ((device-coordinate-limits) + (graphics-device-type/operation/device-coordinate-limits type)) + ((drag-cursor) + (graphics-device-type/operation/drag-cursor type)) + ((draw-line) + (graphics-device-type/operation/draw-line type)) + ((draw-point) + (graphics-device-type/operation/draw-point type)) + ((draw-text) + (graphics-device-type/operation/draw-text type)) + ((flush) + (graphics-device-type/operation/flush type)) + ((move-cursor) + (graphics-device-type/operation/move-cursor type)) + ((reset-clip-rectangle) + (graphics-device-type/operation/reset-clip-rectangle type)) + ((set-clip-rectangle) + (graphics-device-type/operation/set-clip-rectangle type)) + ((set-coordinate-limits) + (graphics-device-type/operation/set-coordinate-limits type)) + ((set-drawing-mode) + (graphics-device-type/operation/set-drawing-mode type)) + ((set-line-style) + (graphics-device-type/operation/set-line-style type)) + (else + (let ((entry (assq name (graphics-device-type/custom-operations type)))) + (if (not entry) + (error "Unknown graphics operation" name type)) + (cdr entry))))) + +(define (graphics-type-available? type) + ((graphics-device-type/operation/available? type))) + +(define-structure (graphics-device + (conc-name graphics-device/) + (constructor %make-graphics-device (type descriptor))) + (type false read-only true) + descriptor + (drawing-mode drawing-mode:dominant) + (line-style line-style:solid) + (buffer? true)) + +(define (make-graphics-device type . arguments) + (%make-graphics-device type + (apply (graphics-device-type/operation/open type) + arguments))) + +(let-syntax + ((define-graphics-operation + (macro (name) + `(DEFINE-INTEGRABLE + (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE) + (,(symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/ name) + (GRAPHICS-DEVICE/TYPE DEVICE)))))) + (define-graphics-operation clear) + (define-graphics-operation close) + (define-graphics-operation coordinate-limits) + (define-graphics-operation device-coordinate-limits) + (define-graphics-operation drag-cursor) + (define-graphics-operation draw-line) + (define-graphics-operation draw-point) + (define-graphics-operation draw-text) + (define-graphics-operation flush) + (define-graphics-operation move-cursor) + (define-graphics-operation reset-clip-rectangle) + (define-graphics-operation set-clip-rectangle) + (define-graphics-operation set-coordinate-limits) + (define-graphics-operation set-drawing-mode) + (define-graphics-operation set-line-style)) + +(define (graphics-operation device name . arguments) + (let ((value + (apply (graphics-device-type/operation (graphics-device/type device) + name) + (graphics-device/descriptor device) + arguments))) + (maybe-flush device) + value)) + +(define (graphics-enable-buffering device) + (set-graphics-device/buffer?! device true)) + +(define (graphics-disable-buffering device) + (set-graphics-device/buffer?! device false)) + +(define (maybe-flush device) + (if (graphics-device/buffer? device) + (graphics-flush device))) + +(define (graphics-close device) + ((graphics-device/operation/close device) + (graphics-device/descriptor device))) + +(define-integrable (graphics-flush device) + ((graphics-device/operation/flush device) + (graphics-device/descriptor device))) + +(define (graphics-device-coordinate-limits device) + ((graphics-device/operation/device-coordinate-limits device) + (graphics-device/descriptor device))) + +(define (graphics-coordinate-limits device) + ((graphics-device/operation/coordinate-limits device) + (graphics-device/descriptor device))) + +(define (graphics-set-coordinate-limits device x-left y-bottom x-right y-top) + ((graphics-device/operation/set-coordinate-limits device) + (graphics-device/descriptor device) + x-left y-bottom x-right y-top)) + +(define (graphics-set-clip-rectangle device x-left y-bottom x-right y-top) + ((graphics-device/operation/set-clip-rectangle device) + (graphics-device/descriptor device) + x-left y-bottom x-right y-top)) + +(define (graphics-reset-clip-rectangle device) + ((graphics-device/operation/reset-clip-rectangle device) + (graphics-device/descriptor device))) + +(define-integrable drawing-mode:erase 0) +(define-integrable drawing-mode:non-dominant 1) +(define-integrable drawing-mode:complement 2) +(define-integrable drawing-mode:dominant 3) + +(define (graphics-bind-drawing-mode device drawing-mode thunk) + (let ((old-mode (graphics-device/drawing-mode device))) + (dynamic-wind + (lambda () + (graphics-set-drawing-mode device drawing-mode)) + thunk + (lambda () + (graphics-set-drawing-mode device old-mode))))) + +(define (graphics-set-drawing-mode device drawing-mode) + ((graphics-device/operation/set-drawing-mode device) + (graphics-device/descriptor device) + drawing-mode) + (set-graphics-device/drawing-mode! device drawing-mode)) + +(define-integrable line-style:solid 0) +(define-integrable line-style:dash 1) +(define-integrable line-style:dot 2) +(define-integrable line-style:dash-dot 3) +(define-integrable line-style:dash-dot-dot 4) +(define-integrable line-style:long-dash 5) +(define-integrable line-style:center-dash 6) +(define-integrable line-style:center-dash-dash 7) + +(define (graphics-bind-line-style device line-style thunk) + (let ((old-style (graphics-device/line-style device))) + (dynamic-wind + (lambda () + (graphics-set-line-style device line-style)) + thunk + (lambda () + (graphics-set-line-style device old-style))))) + +(define (graphics-set-line-style device line-style) + ((graphics-device/operation/set-line-style device) + (graphics-device/descriptor device) + line-style) + (set-graphics-device/line-style! device line-style)) + +(define (graphics-clear device) + ((graphics-device/operation/clear device) + (graphics-device/descriptor device)) + (maybe-flush device)) + +(define (graphics-draw-point device x y) + ((graphics-device/operation/draw-point device) + (graphics-device/descriptor device) + x y) + (maybe-flush device)) + +(define (graphics-erase-point device x y) + (graphics-bind-drawing-mode device drawing-mode:erase + (lambda () + (graphics-draw-point device x y)))) + +(define (graphics-draw-text device x y text) + ((graphics-device/operation/draw-text device) + (graphics-device/descriptor device) + x y text) + (maybe-flush device)) + +(define (graphics-draw-line device x-start y-start x-end y-end) + ((graphics-device/operation/draw-line device) + (graphics-device/descriptor device) + x-start y-start x-end y-end) + (maybe-flush device)) + +(define (graphics-move-cursor device x y) + ((graphics-device/operation/move-cursor device) + (graphics-device/descriptor device) + x y)) + +(define (graphics-drag-cursor device x y) + ((graphics-device/operation/drag-cursor device) + (graphics-device/descriptor device) + x y) + (maybe-flush device)) \ No newline at end of file diff --git a/v7/src/runtime/starbase.scm b/v7/src/runtime/starbase.scm new file mode 100644 index 000000000..93e835291 --- /dev/null +++ b/v7/src/runtime/starbase.scm @@ -0,0 +1,232 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/starbase.scm,v 1.1 1989/06/23 00:01:43 cph Rel $ + +Copyright (c) 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Starbase Graphics Interface +;;; package: (runtime starbase-graphics) + +(declare (usual-integrations)) + +(define-primitives + (starbase-open-device 2) + (starbase-close-device 1) + (starbase-flush 1) + (starbase-clear 1) + (starbase-move-cursor 3) + (starbase-drag-cursor 3) + (starbase-draw-line 5) + (starbase-draw-point 3) + (starbase-set-line-style 2) + (starbase-set-drawing-mode 2) + (starbase-device-coordinates 1) + (starbase-set-vdc-extent 5) + (starbase-reset-clip-rectangle 1) + (starbase-set-clip-rectangle 5) + (starbase-draw-text 4) + (starbase-set-text-height 2) + (starbase-set-text-aspect 2) + (starbase-set-text-slant 2) + (starbase-set-text-rotation 2) + (starbase-color-map-size 1) + (starbase-define-color 5) + (starbase-set-line-color 2) + (starbase-write-image-file 3)) + +(define (initialize-package!) + (set! starbase-graphics-device-type + (make-graphics-device-type + `((available? ,operation/available?) + (clear ,operation/clear) + (close ,operation/close) + (color-map-size ,operation/color-map-size) + (coordinate-limits ,operation/coordinate-limits) + (define-color ,operation/define-color) + (device-coordinate-limits ,operation/device-coordinate-limits) + (drag-cursor ,operation/drag-cursor) + (draw-line ,operation/draw-line) + (draw-point ,operation/draw-point) + (draw-text ,operation/draw-text) + (flush ,operation/flush) + (move-cursor ,operation/move-cursor) + (open ,operation/open) + (reset-clip-rectangle ,operation/reset-clip-rectangle) + (set-clip-rectangle ,operation/set-clip-rectangle) + (set-coordinate-limits ,operation/set-coordinate-limits) + (set-drawing-mode ,operation/set-drawing-mode) + (set-line-color ,operation/set-line-color) + (set-line-style ,operation/set-line-style) + (set-text-aspect ,operation/set-text-aspect) + (set-text-height ,operation/set-text-height) + (set-text-rotation ,operation/set-text-rotation) + (set-text-slant ,operation/set-text-slant) + (text-aspect ,operation/text-aspect) + (text-height ,operation/text-height) + (text-rotation ,operation/text-rotation) + (text-slant ,operation/text-slant) + (write-image-file ,operation/write-image-file)))) + unspecific) + +(define starbase-graphics-device-type) + +(define-structure (starbase-device + (conc-name starbase-device/) + (constructor make-starbase-device (descriptor))) + (descriptor false read-only true) + x-left + y-bottom + x-right + y-top + text-height + text-aspect + text-slant + text-rotation) + +(define (operation/available?) + (implemented-primitive-procedure? starbase-open-device)) + +(define (operation/open device-name driver-name) + (let ((device + (make-starbase-device + (starbase-open-device device-name driver-name)))) + (operation/set-coordinate-limits device -1 -1 1 1) + (operation/set-text-height device 0.1) + (operation/set-text-aspect device 1) + (operation/set-text-slant device 0) + (operation/set-text-rotation device 0) + device)) + +(define (operation/close device) + (starbase-close-device (starbase-device/descriptor device))) + +(define (operation/flush device) + (starbase-flush (starbase-device/descriptor device))) + +(define (operation/device-coordinate-limits device) + (let ((limits + (starbase-device-coordinates + (starbase-device/descriptor device)))) + (values (vector-ref limits 0) + (vector-ref limits 1) + (vector-ref limits 2) + (vector-ref limits 3)))) + +(define (operation/coordinate-limits device) + (values (starbase-device/x-left device) + (starbase-device/y-bottom device) + (starbase-device/x-right device) + (starbase-device/y-top device))) + +(define (operation/set-coordinate-limits device x-left y-bottom x-right y-top) + (starbase-set-vdc-extent (starbase-device/descriptor device) + x-left y-bottom x-right y-top) + (set-starbase-device/x-left! device x-left) + (set-starbase-device/y-bottom! device y-bottom) + (set-starbase-device/x-right! device x-right) + (set-starbase-device/y-top! device y-top)) + +(define (operation/reset-clip-rectangle device) + (starbase-reset-clip-rectangle (starbase-device/descriptor device))) + +(define (operation/set-clip-rectangle device x-left y-bottom x-right y-top) + (starbase-set-clip-rectangle (starbase-device/descriptor device) + x-left y-bottom x-right y-top)) + +(define (operation/set-drawing-mode device drawing-mode) + (starbase-set-drawing-mode (starbase-device/descriptor device) drawing-mode)) + +(define (operation/set-line-style device line-style) + (starbase-set-line-style (starbase-device/descriptor device) line-style)) + +(define (operation/clear device) + (starbase-clear (starbase-device/descriptor device))) + +(define (operation/draw-point device x y) + (starbase-draw-point (starbase-device/descriptor device) x y)) + +(define (operation/move-cursor device x y) + (starbase-move-cursor (starbase-device/descriptor device) x y)) + +(define (operation/drag-cursor device x y) + (starbase-drag-cursor (starbase-device/descriptor device) x y)) + +(define (operation/draw-line device x-start y-start x-end y-end) + (starbase-draw-line (starbase-device/descriptor device) + x-start y-start x-end y-end)) + +(define (operation/draw-text device x y text) + (starbase-draw-text (starbase-device/descriptor device) x y text)) + +;;; Custom Operations + +(define (operation/write-image-file device filename invert?) + (starbase-write-image-file (starbase-device/descriptor device) + (canonicalize-output-filename filename) + invert?)) + +(define (operation/text-height device) + (starbase-device/text-height (starbase-device/descriptor device))) + +(define (operation/text-aspect device) + (starbase-device/text-aspect (starbase-device/descriptor device))) + +(define (operation/text-slant device) + (starbase-device/text-slant (starbase-device/descriptor device))) + +(define (operation/text-rotation device) + (starbase-device/text-rotation (starbase-device/descriptor device))) + +(define (operation/set-text-height device height) + (starbase-set-text-height (starbase-device/descriptor device) height) + (set-starbase-device/text-height! device height)) + +(define (operation/set-text-aspect device aspect) + (starbase-set-text-aspect (starbase-device/descriptor device) aspect) + (set-starbase-device/text-aspect! device aspect)) + +(define (operation/set-text-slant device slant) + (starbase-set-text-slant (starbase-device/descriptor device) slant) + (set-starbase-device/text-slant! device slant)) + +(define (operation/set-text-rotation device rotation) + (starbase-set-text-rotation (starbase-device/descriptor device) rotation) + (set-starbase-device/text-rotation! device rotation)) + +(define (operation/color-map-size device) + (starbase-color-map-size (starbase-device/descriptor device))) + +(define (operation/define-color device color-index red green blue) + (starbase-define-color (starbase-device/descriptor device) + color-index red green blue)) + +(define (operation/set-line-color device color-index) + (starbase-set-line-color (starbase-device/descriptor device) color-index)) \ No newline at end of file diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm new file mode 100644 index 000000000..6ed9cd148 --- /dev/null +++ b/v7/src/runtime/x11graph.scm @@ -0,0 +1,175 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.1 1989/06/22 23:58:39 cph Exp $ + +Copyright (c) 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; X Graphics Interface +;;; package: (runtime X-graphics) + +(declare (usual-integrations)) + +(define-primitives + (x-debug 1) + (x-open-display 1) + (x-close-display 1) + (x-close-all-displays 0) + (x-close-window 1) + (x-window-read-event-flags! 1) + (x-window-x-size 1) + (x-window-y-size 1) + (x-window-map 1) + (x-window-unmap 1) + (x-window-beep 1) + (x-window-clear 1) + (x-window-flush 1) + (x-window-get-default 3) + (x-window-set-foreground-color 2) + (x-window-set-background-color 2) + (x-window-set-border-color 2) + (x-window-set-cursor-color 2) + (x-window-set-mouse-color 2) + (x-window-set-mouse-shape 2) + (x-window-set-font 2) + (x-window-set-border-width 2) + (x-window-set-internal-border-width 2) + (x-window-set-size 3) + (x-window-set-position 3) + (x-window-starbase-filename 1) + (x-graphics-open-window 3) + (x-graphics-vdc-extent 1) + (x-graphics-set-vdc-extent 5) + (x-graphics-reset-clip-rectangle 1) + (x-graphics-set-clip-rectangle 5) + (x-graphics-move-cursor 3) + (x-graphics-drag-cursor 3) + (x-graphics-draw-line 5) + (x-graphics-draw-point 3) + (x-graphics-draw-string 4) + (x-graphics-set-function 2) + (x-graphics-set-fill-style 2) + (x-graphics-set-line-style 2) + (x-graphics-set-dashes 3) + (x-graphics-process-events 1)) + +(define (initialize-package!) + (set! x-graphics-device-type + (make-graphics-device-type + `((available? ,operation/available?) + (clear ,x-window-clear) + (close ,x-close-window) + (coordinate-limits ,operation/coordinate-limits) + (device-coordinate-limits ,operation/device-coordinate-limits) + (drag-cursor ,x-graphics-drag-cursor) + (draw-line ,x-graphics-draw-line) + (draw-point ,x-graphics-draw-point) + (draw-text ,x-graphics-draw-string) + (flush ,operation/flush) + (map-window ,x-window-map) + (move-cursor ,x-graphics-move-cursor) + (move-window ,x-window-set-position) + (open ,operation/open) + (reset-clip-rectangle ,x-graphics-reset-clip-rectangle) + (resize-window ,x-window-set-size) + (set-background-color ,x-window-set-background-color) + (set-border-color ,x-window-set-border-color) + (set-border-width ,x-window-set-border-width) + (set-clip-rectangle ,x-graphics-set-clip-rectangle) + (set-coordinate-limits ,x-graphics-set-vdc-extent) + (set-drawing-mode ,x-graphics-set-function) + (set-font ,x-window-set-font) + (set-foreground-color ,x-window-set-foreground-color) + (set-internal-border-width ,x-window-set-internal-border-width) + (set-line-style ,operation/set-line-style) + (set-mouse-color ,x-window-set-mouse-color) + (set-mouse-shape ,x-window-set-mouse-shape) + (starbase-filename ,x-window-starbase-filename) + (unmap-window ,x-window-unmap)))) + (add-event-receiver! event:before-exit x-close-all-displays) + unspecific) + +(define x-graphics-device-type) + +(define (x-geometry-string x y width height) + (string-append (if (and width height) + (string-append (number->string width) + "x" + (number->string height)) + "") + (if (and x y) + (string-append (if (negative? x) "" "+") + (number->string x) + (if (negative? y) "" "+") + (number->string y)) + ""))) + +(define (operation/available?) + (implemented-primitive-procedure? x-graphics-open-window)) + +(define (operation/open display geometry #!optional suppress-map?) + (x-graphics-open-window (or display (x-open-display false)) + geometry + (and (not (default-object? suppress-map?)) + suppress-map?))) + +(define (operation/flush xw) + (x-window-flush xw) + (x-graphics-process-events xw)) + +(define (operation/device-coordinate-limits xw) + (x-graphics-process-events xw) + (values 0 (-1+ (x-window-y-size xw)) (-1+ (x-window-x-size xw)) 0)) + +(define (operation/coordinate-limits xw) + (let ((limits (x-graphics-vdc-extent xw))) + (values (vector-ref limits 0) + (vector-ref limits 1) + (vector-ref limits 2) + (vector-ref limits 3)))) + +(define (operation/set-line-style xw line-style) + (cond ((zero? line-style) + (x-graphics-set-line-style xw 0)) + ((and (integer? line-style) (<= 1 line-style 7)) + (x-graphics-set-line-style xw 2) + (x-graphics-set-dashes + xw + 0 + (vector-ref '#("\010\010" + "\001\001" + "\015\001\001\001" + "\013\001\001\001\001\001" + "\013\005" + "\014\001\002\001" + "\011\001\002\001\002\001") + (-1+ line-style)))) + (else + (error "Illegal line style" line-style)))) \ No newline at end of file -- 2.25.1