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 / graphics.scm < prev    next >
Text File  |  1999-01-02  |  17KB  |  483 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: graphics.scm,v 1.17 1999/01/02 06:11:34 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. ;;;; Graphics Operations
  23. ;;; package: (runtime graphics)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-structure (graphics-device-type
  28.            (conc-name graphics-device-type/)
  29.            (constructor
  30.             %make-graphics-device-type
  31.             (name
  32.              operation/available?
  33.              operation/clear
  34.              operation/close
  35.              operation/coordinate-limits
  36.              operation/device-coordinate-limits
  37.              operation/drag-cursor
  38.              operation/draw-line
  39.              operation/draw-point
  40.              operation/draw-text
  41.              operation/flush
  42.              operation/move-cursor
  43.              operation/open
  44.              operation/reset-clip-rectangle
  45.              operation/set-clip-rectangle
  46.              operation/set-coordinate-limits
  47.              operation/set-drawing-mode
  48.              operation/set-line-style
  49.              custom-operations))
  50.            (print-procedure
  51.             (standard-unparser-method 'GRAPHICS-TYPE
  52.               (lambda (type port)
  53.             (write-char #\space port)
  54.             (write (graphics-device-type/name type) port)))))
  55.   (name false read-only true)
  56.   (operation/available? false read-only true)
  57.   (operation/clear false read-only true)
  58.   (operation/close false read-only true)
  59.   (operation/coordinate-limits false read-only true)
  60.   (operation/device-coordinate-limits false read-only true)
  61.   (operation/drag-cursor false read-only true)
  62.   (operation/draw-line false read-only true)
  63.   (operation/draw-point false read-only true)
  64.   (operation/draw-text false read-only true)
  65.   (operation/flush false read-only true)
  66.   (operation/move-cursor false read-only true)
  67.   (operation/open false read-only true)
  68.   (operation/reset-clip-rectangle false read-only true)
  69.   (operation/set-clip-rectangle false read-only true)
  70.   (operation/set-coordinate-limits false read-only true)
  71.   (operation/set-drawing-mode false read-only true)
  72.   (operation/set-line-style false read-only true)
  73.   (custom-operations false read-only true)
  74.   (properties (make-1d-table) read-only true))
  75.  
  76. (define (make-graphics-device-type name operations)
  77.   (let ((operations
  78.      (map (lambda (entry)
  79.         (if (not (and (pair? entry)
  80.                   (symbol? (car entry))
  81.                   (pair? (cdr entry))
  82.                   (procedure? (cadr entry))
  83.                   (null? (cddr entry))))
  84.             (error "Malformed operation alist entry" entry))
  85.         (cons (car entry) (cadr entry)))
  86.           operations)))
  87.     (let ((operation
  88.        (lambda (name)
  89.          (let ((entry (assq name operations)))
  90.            (if (not entry)
  91.            (error "Missing operation" name))
  92.            (set! operations (delq! entry operations))
  93.            (cdr entry)))))
  94.       (let ((available? (operation 'available?))
  95.         (clear (operation 'clear))
  96.         (close (operation 'close))
  97.         (coordinate-limits (operation 'coordinate-limits))
  98.         (device-coordinate-limits (operation 'device-coordinate-limits))
  99.         (drag-cursor (operation 'drag-cursor))
  100.         (draw-line (operation 'draw-line))
  101.         (draw-point (operation 'draw-point))
  102.         (draw-text (operation 'draw-text))
  103.         (flush (operation 'flush))
  104.         (move-cursor (operation 'move-cursor))
  105.         (open (operation 'open))
  106.         (reset-clip-rectangle (operation 'reset-clip-rectangle))
  107.         (set-clip-rectangle (operation 'set-clip-rectangle))
  108.         (set-coordinate-limits (operation 'set-coordinate-limits))
  109.         (set-drawing-mode (operation 'set-drawing-mode))
  110.         (set-line-style (operation 'set-line-style)))
  111.     (let ((type
  112.            (%make-graphics-device-type name
  113.                        available?
  114.                        clear
  115.                        close
  116.                        coordinate-limits
  117.                        device-coordinate-limits
  118.                        drag-cursor
  119.                        draw-line
  120.                        draw-point
  121.                        draw-text
  122.                        flush
  123.                        move-cursor
  124.                        open
  125.                        reset-clip-rectangle
  126.                        set-clip-rectangle
  127.                        set-coordinate-limits
  128.                        set-drawing-mode
  129.                        set-line-style
  130.                        operations)))
  131.       (add-graphics-type type)
  132.       type)))))
  133.  
  134. (define (graphics-device-type/operation type name)
  135.   (case name
  136.     ((clear)
  137.      (graphics-device-type/operation/clear type))
  138.     ((close)
  139.      (graphics-device-type/operation/close type))
  140.     ((coordinate-limits)
  141.      (graphics-device-type/operation/coordinate-limits type))
  142.     ((device-coordinate-limits)
  143.      (graphics-device-type/operation/device-coordinate-limits type))
  144.     ((drag-cursor)
  145.      (graphics-device-type/operation/drag-cursor type))
  146.     ((draw-line)
  147.      (graphics-device-type/operation/draw-line type))
  148.     ((draw-point)
  149.      (graphics-device-type/operation/draw-point type))
  150.     ((draw-text)
  151.      (graphics-device-type/operation/draw-text type))
  152.     ((flush)
  153.      (graphics-device-type/operation/flush type))
  154.     ((move-cursor)
  155.      (graphics-device-type/operation/move-cursor type))
  156.     ((reset-clip-rectangle)
  157.      (graphics-device-type/operation/reset-clip-rectangle type))
  158.     ((set-clip-rectangle)
  159.      (graphics-device-type/operation/set-clip-rectangle type))
  160.     ((set-coordinate-limits)
  161.      (graphics-device-type/operation/set-coordinate-limits type))
  162.     ((set-drawing-mode)
  163.      (graphics-device-type/operation/set-drawing-mode type))
  164.     ((set-line-style)
  165.      (graphics-device-type/operation/set-line-style type))
  166.     (else
  167.      (let ((entry (assq name (graphics-device-type/custom-operations type))))
  168.        (if (not entry)
  169.        (error "Unknown graphics operation" name type))
  170.        (cdr entry)))))
  171.  
  172. (define graphics-types '())
  173.  
  174. (define (add-graphics-type type)
  175.   (let ((name (graphics-device-type/name type)))
  176.     (let loop ((types graphics-types))
  177.       (cond ((null? types)
  178.          (set! graphics-types (cons type graphics-types))
  179.          unspecific)
  180.         ((eq? name (graphics-device-type/name (car types)))
  181.          (set-car! types type))
  182.         (else
  183.          (loop (cdr types)))))))
  184.  
  185. (define (graphics-type #!optional object error?)
  186.   (let ((object (if (default-object? object) #f object))
  187.     (error? (if (default-object? error?) #t error?)))
  188.     (let ((test-type
  189.        (lambda (type)
  190.          (if (graphics-device-type/available? type)
  191.          type
  192.          (and error?
  193.               (error "Graphics type not supported:" type))))))
  194.       (cond ((graphics-device-type? object)
  195.          (test-type object))
  196.         ((graphics-device? object)
  197.          (test-type (graphics-device/type object)))
  198.         ((not object)
  199.          (or (list-search-positive graphics-types
  200.            graphics-device-type/available?)
  201.          (and error?
  202.               (error "No graphics types supported."))))
  203.         (else
  204.          (let ((type
  205.             (list-search-positive graphics-types
  206.               (lambda (type)
  207.             (eq? object (graphics-device-type/name type))))))
  208.            (if type
  209.            (test-type type)
  210.            (and error?
  211.             (error "Graphics type unknown:" object)))))))))
  212.  
  213. (define (graphics-type-available? type)
  214.   (graphics-type type #f))
  215.  
  216. (define (enumerate-graphics-types)
  217.   (list-transform-positive graphics-types graphics-device-type/available?))
  218.  
  219. (define (graphics-device-type/available? type)
  220.   ((graphics-device-type/operation/available? type)))
  221.  
  222. (define (graphics-type-name type)
  223.   (guarantee-graphics-type type 'GRAPHICS-TYPE-NAME)
  224.   (graphics-device-type/name type))
  225.  
  226. (define (graphics-type-properties type)
  227.   (guarantee-graphics-type type 'GRAPHICS-TYPE-PROPERTIES)
  228.   (graphics-device-type/properties type))
  229.  
  230. (define (guarantee-graphics-type type name)
  231.   (if (not (graphics-device-type? type))
  232.       (error:wrong-type-argument type "graphics type" name)))
  233.  
  234. (define-structure (graphics-device
  235.            (conc-name graphics-device/)
  236.            (constructor %make-graphics-device (type descriptor)))
  237.   (type false read-only true)
  238.   descriptor
  239.   (drawing-mode drawing-mode:dominant)
  240.   (line-style line-style:solid)
  241.   (buffer? false)
  242.   (properties (make-1d-table) read-only true))
  243.  
  244. (define (make-graphics-device #!optional type-name . arguments)
  245.   (let ((type
  246.      (graphics-type (if (default-object? type-name) #f type-name))))
  247.     (apply (graphics-device-type/operation/open type)
  248.        (lambda (descriptor)
  249.          (and descriptor
  250.           (%make-graphics-device type descriptor)))
  251.        arguments)))
  252.  
  253. (let-syntax
  254.     ((define-graphics-operation
  255.        (macro (name)
  256.      `(DEFINE-INTEGRABLE
  257.         (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE)
  258.         (,(symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/ name)
  259.          (GRAPHICS-DEVICE/TYPE DEVICE))))))
  260.   (define-graphics-operation clear)
  261.   (define-graphics-operation close)
  262.   (define-graphics-operation coordinate-limits)
  263.   (define-graphics-operation device-coordinate-limits)
  264.   (define-graphics-operation drag-cursor)
  265.   (define-graphics-operation draw-line)
  266.   (define-graphics-operation draw-point)
  267.   (define-graphics-operation draw-text)
  268.   (define-graphics-operation flush)
  269.   (define-graphics-operation move-cursor)
  270.   (define-graphics-operation reset-clip-rectangle)
  271.   (define-graphics-operation set-clip-rectangle)
  272.   (define-graphics-operation set-coordinate-limits)
  273.   (define-graphics-operation set-drawing-mode)
  274.   (define-graphics-operation set-line-style))
  275.  
  276. (define (graphics-operation device name . arguments)
  277.   (let ((value
  278.      (apply (graphics-device-type/operation (graphics-device/type device)
  279.                         name)
  280.         device
  281.         arguments)))
  282.     (maybe-flush device)
  283.     value))
  284.  
  285. (define (graphics-enable-buffering device)
  286.   (set-graphics-device/buffer?! device true))
  287.  
  288. (define (graphics-disable-buffering device)
  289.   (if (graphics-device/buffer? device)
  290.       (graphics-flush device))
  291.   (set-graphics-device/buffer?! device false))
  292.  
  293. (define-integrable (maybe-flush device)
  294.   (if (not (graphics-device/buffer? device))
  295.       (graphics-flush device)))
  296.  
  297. (define (graphics-close device)
  298.   ((graphics-device/operation/close device) device))
  299.  
  300. (define-integrable (graphics-flush device)
  301.   ((graphics-device/operation/flush device) device))
  302.  
  303. (define (graphics-device-coordinate-limits device)
  304.   ((graphics-device/operation/device-coordinate-limits device) device))
  305.  
  306. (define (graphics-coordinate-limits device)
  307.   ((graphics-device/operation/coordinate-limits device) device))
  308.  
  309. (define (graphics-set-coordinate-limits device x-left y-bottom x-right y-top)
  310.   ((graphics-device/operation/set-coordinate-limits device)
  311.    device x-left y-bottom x-right y-top))
  312.  
  313. (define (graphics-set-clip-rectangle device x-left y-bottom x-right y-top)
  314.   ((graphics-device/operation/set-clip-rectangle device)
  315.    device x-left y-bottom x-right y-top))
  316.  
  317. (define (graphics-reset-clip-rectangle device)
  318.   ((graphics-device/operation/reset-clip-rectangle device) device))
  319.  
  320. (define-integrable drawing-mode:erase 0)
  321. (define-integrable drawing-mode:non-dominant 1)
  322. (define-integrable drawing-mode:complement 2)
  323. (define-integrable drawing-mode:dominant 3)
  324.  
  325. (define (graphics-bind-drawing-mode device drawing-mode thunk)
  326.   (let ((old-mode (graphics-device/drawing-mode device)))
  327.     (dynamic-wind
  328.      (lambda ()
  329.        (graphics-set-drawing-mode device drawing-mode))
  330.      thunk
  331.      (lambda ()
  332.        (graphics-set-drawing-mode device old-mode)))))
  333.  
  334. (define (graphics-set-drawing-mode device drawing-mode)
  335.   ((graphics-device/operation/set-drawing-mode device)
  336.    device drawing-mode)
  337.   (set-graphics-device/drawing-mode! device drawing-mode))
  338.  
  339. (define-integrable line-style:solid 0)
  340. (define-integrable line-style:dash 1)
  341. (define-integrable line-style:dot 2)
  342. (define-integrable line-style:dash-dot 3)
  343. (define-integrable line-style:dash-dot-dot 4)
  344. (define-integrable line-style:long-dash 5)
  345. (define-integrable line-style:center-dash 6)
  346. (define-integrable line-style:center-dash-dash 7)
  347.  
  348. (define (graphics-bind-line-style device line-style thunk)
  349.   (let ((old-style (graphics-device/line-style device)))
  350.     (dynamic-wind
  351.      (lambda ()
  352.        (graphics-set-line-style device line-style))
  353.      thunk
  354.      (lambda ()
  355.        (graphics-set-line-style device old-style)))))
  356.  
  357. (define (graphics-set-line-style device line-style)
  358.   ((graphics-device/operation/set-line-style device) device line-style)
  359.   (set-graphics-device/line-style! device line-style))
  360.  
  361. (define (graphics-clear device)
  362.   ((graphics-device/operation/clear device) device)
  363.   (maybe-flush device))
  364.  
  365. (define (graphics-draw-point device x y)
  366.   ((graphics-device/operation/draw-point device) device x y)
  367.   (maybe-flush device))
  368.  
  369. (define (graphics-erase-point device x y)
  370.   (graphics-bind-drawing-mode device drawing-mode:erase
  371.     (lambda ()
  372.       (graphics-draw-point device x y))))
  373.  
  374. (define (graphics-draw-text device x y text)
  375.   ((graphics-device/operation/draw-text device) device x y text)
  376.   (maybe-flush device))
  377.  
  378. (define (graphics-draw-line device x-start y-start x-end y-end)
  379.   ((graphics-device/operation/draw-line device)
  380.    device x-start y-start x-end y-end)
  381.   (maybe-flush device))
  382.  
  383. (define (graphics-move-cursor device x y)
  384.   ((graphics-device/operation/move-cursor device) device x y))
  385.  
  386. (define (graphics-drag-cursor device x y)
  387.   ((graphics-device/operation/drag-cursor device) device x y)
  388.   (maybe-flush device))
  389.  
  390. ;;;; Images
  391. ;;; rectangular images that can be copied from and into the graphics
  392. ;;; device
  393.  
  394. (define-structure (image-device-type
  395.            (conc-name image-type/)
  396.            (constructor %make-image-type)
  397.            (predicate image-type?))
  398.   (operation/create  false read-only true)
  399.   (operation/destroy false read-only true)
  400.   (operation/width   false read-only true)
  401.   (operation/height  false read-only true)
  402.   (operation/draw    false read-only true)
  403.   (operation/draw-subimage    false read-only true)
  404.   (operation/fill-from-byte-vector  false read-only true))
  405.  
  406. (define (image-type #!optional object error?)
  407.   (let ((object (if (default-object? object) #f object))
  408.     (error? (if (default-object? error?) #t error?)))
  409.     (if (image-type? object)
  410.     object
  411.     (let ((type (graphics-type object error?)))
  412.       (and type
  413.            (or (1d-table/get (graphics-type-properties type)
  414.                  'IMAGE-TYPE
  415.                  #f)
  416.            (and error?
  417.             (error "Graphics type has no associated image type:"
  418.                    type))))))))
  419.  
  420. (define (make-image-type operations)
  421.   (let ((operations
  422.      (map (lambda (entry)
  423.         (if (not (and (pair? entry)
  424.                   (symbol? (car entry))
  425.                   (pair? (cdr entry))
  426.                   (procedure? (cadr entry))
  427.                   (null? (cddr entry))))
  428.             (error "Malformed operation alist entry" entry))
  429.         (cons (car entry) (cadr entry)))
  430.           operations)))
  431.     (let ((operation
  432.        (lambda (name)
  433.          (let ((entry (assq name operations)))
  434.            (if (not entry)
  435.            (error "Missing operation" name))
  436.            (set! operations (delq! entry operations))
  437.            (cdr entry)))))
  438.       (let ((create   (operation 'create))
  439.         (destroy  (operation 'destroy))
  440.         (width    (operation 'width))
  441.         (height   (operation 'height))
  442.         (draw     (operation 'draw))
  443.         (draw-subimage (operation 'draw-subimage))
  444.         (fill-from-byte-vector (operation 'fill-from-byte-vector)))
  445.     (if (not (null? operations))
  446.         (error "Extra image type operations: " operations)
  447.         (%make-image-type create destroy 
  448.                   width height 
  449.                   draw draw-subimage fill-from-byte-vector))))))
  450.  
  451. (define-structure (image (conc-name image/) (constructor %make-image))
  452.   type
  453.   descriptor)
  454.  
  455. (define the-destroyed-image-type #f)
  456.  
  457. (define (image/create device width height)
  458.   ;; operation/create returns a descriptor
  459.   (let ((type (image-type device)))
  460.     (%make-image type
  461.          ((image-type/operation/create type) device width height))))
  462.  
  463. (define (image/destroy image)
  464.   ((image-type/operation/destroy (image/type image)) image)
  465.   (set-image/type! image the-destroyed-image-type)
  466.   (set-image/descriptor! image #f))
  467.  
  468. (define (image/width image)
  469.   ((image-type/operation/width (image/type image)) image))
  470.  
  471. (define (image/height image)
  472.   ((image-type/operation/height (image/type image)) image))
  473.  
  474. (define (image/draw device x y image)
  475.   ((image-type/operation/draw (image/type image)) device x y image))
  476.  
  477. (define (image/draw-subimage device x y image im-x im-y width height)
  478.   ((image-type/operation/draw-subimage (image/type image))
  479.    device x y image im-x im-y width height))
  480.  
  481. (define (image/fill-from-byte-vector image byte-vector)
  482.   ((image-type/operation/fill-from-byte-vector (image/type image))
  483.    image byte-vector))