--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+(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)))))
+\f
+(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)))
+\f
+(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)))
+\f
+(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))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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)
+\f
+(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))
+\f
+;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+(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))
+ "")))
+\f
+(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
projects / mit-scheme.git / commitdiff