home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / starbase.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  245 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: starbase.scm,v 1.13 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Starbase Graphics Interface
  23. ;;; package: (runtime starbase-graphics)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-primitives
  28.   (starbase-open-device 2)
  29.   (starbase-close-device 1)
  30.   (starbase-flush 1)
  31.   (starbase-clear 1)
  32.   (starbase-move-cursor 3)
  33.   (starbase-drag-cursor 3)
  34.   (starbase-draw-line 5)
  35.   (starbase-draw-point 3)
  36.   (starbase-set-line-style 2)
  37.   (starbase-set-drawing-mode 2)
  38.   (starbase-device-coordinates 1)
  39.   (starbase-set-vdc-extent 5)
  40.   (starbase-reset-clip-rectangle 1)
  41.   (starbase-set-clip-rectangle 5)
  42.   (starbase-draw-text 4)
  43.   (starbase-set-text-height 2)
  44.   (starbase-set-text-aspect 2)
  45.   (starbase-set-text-slant 2)
  46.   (starbase-set-text-rotation 2)
  47.   (starbase-color-map-size 1)
  48.   (starbase-define-color 5)
  49.   (starbase-set-line-color 2)
  50.   (starbase-write-image-file 3))
  51.  
  52. (define (initialize-package!)
  53.   (set! starbase-graphics-device-type
  54.     (make-graphics-device-type
  55.      'STARBASE
  56.      `((available? ,operation/available?)
  57.        (clear ,operation/clear)
  58.        (close ,operation/close)
  59.        (color-map-size ,operation/color-map-size)
  60.        (coordinate-limits ,operation/coordinate-limits)
  61.        (define-color ,operation/define-color)
  62.        (device-coordinate-limits ,operation/device-coordinate-limits)
  63.        (drag-cursor ,operation/drag-cursor)
  64.        (draw-line ,operation/draw-line)
  65.        (draw-point ,operation/draw-point)
  66.        (draw-text ,operation/draw-text)
  67.        (flush ,operation/flush)
  68.        (move-cursor ,operation/move-cursor)
  69.        (open ,operation/open)
  70.        (reset-clip-rectangle ,operation/reset-clip-rectangle)
  71.        (set-clip-rectangle ,operation/set-clip-rectangle)
  72.        (set-coordinate-limits ,operation/set-coordinate-limits)
  73.        (set-drawing-mode ,operation/set-drawing-mode)
  74.        (set-line-color ,operation/set-line-color)
  75.        (set-line-style ,operation/set-line-style)
  76.        (set-text-aspect ,operation/set-text-aspect)
  77.        (set-text-height ,operation/set-text-height)
  78.        (set-text-rotation ,operation/set-text-rotation)
  79.        (set-text-slant ,operation/set-text-slant)
  80.        (text-aspect ,operation/text-aspect)
  81.        (text-height ,operation/text-height)
  82.        (text-rotation ,operation/text-rotation)
  83.        (text-slant ,operation/text-slant)
  84.        (write-image-file ,operation/write-image-file))))
  85.   unspecific)
  86.  
  87. (define starbase-graphics-device-type)
  88.  
  89. (define-structure (starbase-graphics-descriptor
  90.            (conc-name starbase-graphics-descriptor/)
  91.            (constructor make-starbase-descriptor (identifier)))
  92.   (identifier false read-only true)
  93.   x-left
  94.   y-bottom
  95.   x-right
  96.   y-top
  97.   text-height
  98.   text-aspect
  99.   text-slant
  100.   text-rotation)
  101.  
  102. (define (starbase-device/identifier device)
  103.   (starbase-graphics-descriptor/identifier
  104.    (graphics-device/descriptor device)))
  105.  
  106. (let-syntax
  107.     ((define-accessors-and-mutators
  108.        (macro (name)
  109.      `(BEGIN
  110.         (DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE)
  111.           (,(symbol-append 'STARBASE-GRAPHICS-DESCRIPTOR/ name)
  112.            (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)))
  113.         (DEFINE (,(symbol-append 'SET-STARBASE-DEVICE/ name '!)
  114.              DEVICE VALUE)
  115.           (,(symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!)
  116.            (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)
  117.            VALUE))))))
  118.   (define-accessors-and-mutators x-left)
  119.   (define-accessors-and-mutators y-bottom)
  120.   (define-accessors-and-mutators x-right)
  121.   (define-accessors-and-mutators y-top)
  122.   (define-accessors-and-mutators text-height)
  123.   (define-accessors-and-mutators text-aspect)
  124.   (define-accessors-and-mutators text-slant)
  125.   (define-accessors-and-mutators text-rotation))
  126.  
  127. (define (operation/available?)
  128.   (implemented-primitive-procedure? starbase-open-device))
  129.  
  130. (define (operation/open descriptor->device device-name driver-name)
  131.   (let ((identifier (starbase-open-device device-name driver-name)))
  132.     (and identifier
  133.      (let ((descriptor (make-starbase-descriptor identifier)))
  134.        (operation/set-coordinate-limits descriptor -1 -1 1 1)
  135.        (operation/set-text-height descriptor 0.1)
  136.        (operation/set-text-aspect descriptor 1)
  137.        (operation/set-text-slant descriptor 0)
  138.        (operation/set-text-rotation descriptor 0)
  139.        (descriptor->device descriptor)))))
  140.  
  141. (define (operation/close device)
  142.   (starbase-close-device (starbase-device/identifier device)))
  143.  
  144. (define (operation/flush device)
  145.   (starbase-flush (starbase-device/identifier device)))
  146.  
  147. (define (operation/device-coordinate-limits device)
  148.   (let ((limits
  149.      (starbase-device-coordinates
  150.       (starbase-device/identifier device))))
  151.     (values (vector-ref limits 0)
  152.         (vector-ref limits 1)
  153.         (vector-ref limits 2)
  154.         (vector-ref limits 3))))
  155.  
  156. (define (operation/coordinate-limits device)
  157.   (values (starbase-device/x-left device)
  158.       (starbase-device/y-bottom device)
  159.       (starbase-device/x-right device)
  160.       (starbase-device/y-top device)))
  161.  
  162. (define (operation/set-coordinate-limits device x-left y-bottom x-right y-top)
  163.   (starbase-set-vdc-extent (starbase-device/identifier device)
  164.                x-left y-bottom x-right y-top)
  165.   (set-starbase-device/x-left! device x-left)
  166.   (set-starbase-device/y-bottom! device y-bottom)
  167.   (set-starbase-device/x-right! device x-right)
  168.   (set-starbase-device/y-top! device y-top))
  169.  
  170. (define (operation/reset-clip-rectangle device)
  171.   (starbase-reset-clip-rectangle (starbase-device/identifier device)))
  172.  
  173. (define (operation/set-clip-rectangle device x-left y-bottom x-right y-top)
  174.   (starbase-set-clip-rectangle (starbase-device/identifier device)
  175.                    x-left y-bottom x-right y-top))
  176.  
  177. (define (operation/set-drawing-mode device drawing-mode)
  178.   (starbase-set-drawing-mode (starbase-device/identifier device) drawing-mode))
  179.  
  180. (define (operation/set-line-style device line-style)
  181.   (starbase-set-line-style (starbase-device/identifier device) line-style))
  182.  
  183. (define (operation/clear device)
  184.   (starbase-clear (starbase-device/identifier device)))
  185.  
  186. (define (operation/draw-point device x y)
  187.   (starbase-draw-point (starbase-device/identifier device) x y))
  188.  
  189. (define (operation/move-cursor device x y)
  190.   (starbase-move-cursor (starbase-device/identifier device) x y))
  191.  
  192. (define (operation/drag-cursor device x y)
  193.   (starbase-drag-cursor (starbase-device/identifier device) x y))
  194.  
  195. (define (operation/draw-line device x-start y-start x-end y-end)
  196.   (starbase-draw-line (starbase-device/identifier device)
  197.               x-start y-start x-end y-end))
  198.  
  199. (define (operation/draw-text device x y text)
  200.   (starbase-draw-text (starbase-device/identifier device) x y text))
  201.  
  202. ;;; Custom Operations
  203.  
  204. (define (operation/write-image-file device filename invert?)
  205.   (starbase-write-image-file (starbase-device/identifier device)
  206.                  (->namestring (merge-pathnames filename))
  207.                  invert?))
  208.  
  209. (define (operation/text-height device)
  210.   (starbase-device/text-height device))
  211.  
  212. (define (operation/text-aspect device)
  213.   (starbase-device/text-aspect device))
  214.  
  215. (define (operation/text-slant device)
  216.   (starbase-device/text-slant device))
  217.  
  218. (define (operation/text-rotation device)
  219.   (starbase-device/text-rotation device))
  220.  
  221. (define (operation/set-text-height device height)
  222.   (starbase-set-text-height (starbase-device/identifier device) height)
  223.   (set-starbase-device/text-height! device height))
  224.  
  225. (define (operation/set-text-aspect device aspect)
  226.   (starbase-set-text-aspect (starbase-device/identifier device) aspect)
  227.   (set-starbase-device/text-aspect! device aspect))
  228.  
  229. (define (operation/set-text-slant device slant)
  230.   (starbase-set-text-slant (starbase-device/identifier device) slant)
  231.   (set-starbase-device/text-slant! device slant))
  232.  
  233. (define (operation/set-text-rotation device rotation)
  234.   (starbase-set-text-rotation (starbase-device/identifier device) rotation)
  235.   (set-starbase-device/text-rotation! device rotation))
  236.  
  237. (define (operation/color-map-size device)
  238.   (starbase-color-map-size (starbase-device/identifier device)))
  239.  
  240. (define (operation/define-color device color-index red green blue)
  241.   (starbase-define-color (starbase-device/identifier device)
  242.              color-index red green blue))
  243.  
  244. (define (operation/set-line-color device color-index)
  245.   (starbase-set-line-color (starbase-device/identifier device) color-index))