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 / os2graph.scm < prev    next >
Text File  |  2001-03-21  |  40KB  |  1,167 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: os2graph.scm,v 1.18 2001/03/21 05:39:53 cph Exp $
  4.  
  5. Copyright (c) 1995-2001 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., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; OS/2 PM Graphics Interface
  24. ;;; package: (runtime os2-graphics)
  25.  
  26. (declare (usual-integrations))
  27. (declare (integrate-external "graphics"))
  28. (declare (integrate-external "os2winp"))
  29.  
  30. (define (initialize-package!)
  31.   (set! os2-graphics-device-type
  32.     (make-graphics-device-type
  33.      'OS/2
  34.      `((activate-window ,os2-graphics/activate-window)
  35.        (available? ,os2-graphics/available?)
  36.        (capture-image ,os2-graphics/capture-image)
  37.        (clear ,os2-graphics/clear)
  38.        (close ,os2-graphics/close)
  39.        (color? ,os2-graphics/color?)
  40.        (coordinate-limits ,os2-graphics/coordinate-limits)
  41.        (deactivate-window ,os2-graphics/deactivate-window)
  42.        (define-color ,os2-graphics/define-color)
  43.        (desktop-size ,os2-graphics/desktop-size)
  44.        (device-coordinate-limits ,os2-graphics/device-coordinate-limits)
  45.        (discard-events ,os2-graphics/discard-events)
  46.        (drag-cursor ,os2-graphics/drag-cursor)
  47.        (draw-line ,os2-graphics/draw-line)
  48.        (draw-lines ,os2-graphics/draw-lines)
  49.        (draw-point ,os2-graphics/draw-point)
  50.        (draw-text ,os2-graphics/draw-text)
  51.        (find-color ,os2-graphics/find-color)
  52.        (flush ,os2-graphics/flush)
  53.        (hide-window ,os2-graphics/hide-window)
  54.        (image-depth ,os2-graphics/image-depth)
  55.        (lower-window ,os2-graphics/lower-window)
  56.        (maximize-window ,os2-graphics/maximize-window)
  57.        (minimize-window ,os2-graphics/minimize-window)
  58.        (move-cursor ,os2-graphics/move-cursor)
  59.        (open ,os2-graphics/open)
  60.        (raise-window ,os2-graphics/raise-window)
  61.        (read-button ,os2-graphics/read-button)
  62.        (read-user-event ,os2-graphics/read-user-event)
  63.        (reset-clip-rectangle ,os2-graphics/reset-clip-rectangle)
  64.        (restore-window ,os2-graphics/restore-window)
  65.        (select-user-events ,os2-graphics/select-user-events)
  66.        (set-background-color ,os2-graphics/set-background-color)
  67.        (set-clip-rectangle ,os2-graphics/set-clip-rectangle)
  68.        (set-coordinate-limits ,os2-graphics/set-coordinate-limits)
  69.        (set-drawing-mode ,os2-graphics/set-drawing-mode)
  70.        (set-font ,os2-graphics/set-font)
  71.        (set-foreground-color ,os2-graphics/set-foreground-color)
  72.        (set-line-style ,os2-graphics/set-line-style)
  73.        (set-window-name ,os2-graphics/set-window-title)
  74.        (set-window-position ,os2-graphics/set-window-position)
  75.        (set-window-size ,os2-graphics/set-window-size)
  76.        (set-window-title ,os2-graphics/set-window-title)
  77.        (window-position ,os2-graphics/window-position)
  78.        (window-frame-size ,os2-graphics/window-frame-size)
  79.        (window-size ,os2-graphics/window-size))))
  80.   (1d-table/put!
  81.    (graphics-type-properties os2-graphics-device-type)
  82.    'IMAGE-TYPE
  83.    (make-image-type
  84.     `((create ,os2-image/create)
  85.       (destroy ,os2-image/destroy)
  86.       (width ,os2-image/width)
  87.       (height ,os2-image/height)
  88.       (draw ,os2-image/draw)
  89.       (draw-subimage ,os2-image/draw-subimage)
  90.       (fill-from-byte-vector ,os2-image/fill-from-byte-vector))))
  91.   (set! event-descriptor #f)
  92.   (set! event-previewer-registration #f)
  93.   (set! window-finalizer (make-gc-finalizer os2win-close))
  94.   (set! image-finalizer (make-gc-finalizer destroy-memory-ps))
  95.   (set! user-event-mask user-event-mask:default)
  96.   (set! user-event-queue (make-queue))
  97.   (initialize-color-table)
  98.   (add-event-receiver! event:before-exit finalize-pm-state!))
  99.  
  100. (define os2-graphics-device-type)
  101. (define event-descriptor)
  102. (define event-previewer-registration)
  103. (define window-finalizer)
  104. (define image-finalizer)
  105. (define user-event-mask)
  106. (define user-event-queue)
  107. (define graphics-window-icon)
  108.  
  109. ;; This event mask contains just button events.
  110. (define user-event-mask:default #x0001)
  111.  
  112. (define (finalize-pm-state!)
  113.   (if event-descriptor
  114.       (begin
  115.     (os2win-destroy-pointer graphics-window-icon)
  116.     (set! graphics-window-icon)
  117.     (remove-all-from-gc-finalizer! window-finalizer)
  118.     (remove-all-from-gc-finalizer! image-finalizer)
  119.     (deregister-input-thread-event event-previewer-registration)
  120.     (set! event-previewer-registration #f)
  121.     (set! user-event-mask user-event-mask:default)
  122.     (flush-queue! user-event-queue)
  123.     (os2win-close-event-qid event-descriptor)
  124.     (set! event-descriptor #f)
  125.     unspecific)))
  126.  
  127. ;;;; Window Abstraction
  128.  
  129. (define-structure (window
  130.            (conc-name window/)
  131.            (constructor %make-window (wid pel-width pel-height)))
  132.   wid
  133.   pel-width
  134.   pel-height
  135.   backing-image
  136.   (changes #f)
  137.   (x-gcursor 0)
  138.   (y-gcursor 0)
  139.   (x-left -1)
  140.   (y-bottom -1)
  141.   (x-right 1)
  142.   (y-top 1)
  143.   (x-slope (exact->inexact (/ (- pel-width 1) 2)))
  144.   (y-slope (exact->inexact (/ (- pel-height 1) 2)))
  145.   font-specifier
  146.   font-metrics
  147.   (foreground-color #xFFFFFF)
  148.   (background-color #x000000)
  149.   device)
  150.  
  151. (define (make-window wid width height)
  152.   (let ((window (%make-window wid width height)))
  153.     (set-window/backing-image! window (create-image width height))
  154.     (add-to-gc-finalizer! window-finalizer window wid)
  155.     window))
  156.  
  157. (define (close-window window)
  158.   (if (window/wid window)
  159.       (begin
  160.     (destroy-image (window/backing-image window))
  161.     (remove-from-gc-finalizer! window-finalizer window)
  162.     (set-window/wid! window #f))))
  163.  
  164. (define-integrable (os2-graphics-device/wid device)
  165.   (window/wid (graphics-device/descriptor device)))
  166.  
  167. (define-integrable (os2-graphics-device/psid device)
  168.   (window/backing-store (graphics-device/descriptor device)))
  169.  
  170. (define-integrable (window/backing-store window)
  171.   (image/ps (window/backing-image window)))
  172.  
  173. (define (compute-window-slopes! window)
  174.   (set-window/x-slope!
  175.    window
  176.    (exact->inexact
  177.     (/ (- (window/pel-width window) 1)
  178.        (- (window/x-right window) (window/x-left window)))))
  179.   (set-window/y-slope!
  180.    window
  181.    (exact->inexact
  182.     (/ (- (window/pel-height window) 1)
  183.        (- (window/y-top window) (window/y-bottom window))))))
  184.  
  185. (define (window/x->device window x)
  186.   (round->exact (* (window/x-slope window) (- x (window/x-left window)))))
  187.  
  188. (define (window/y->device window y)
  189.   (round->exact (* (window/y-slope window) (- y (window/y-bottom window)))))
  190.  
  191. (define (window/device->x window x)
  192.   (+ (/ x (window/x-slope window)) (window/x-left window)))
  193.  
  194. (define (window/device->y window y)
  195.   (+ (/ y (window/y-slope window)) (window/y-bottom window)))
  196.  
  197. ;;;; Standard Operations
  198.  
  199. (define (os2-graphics/available?)
  200.   (implemented-primitive-procedure? os2win-open))
  201.  
  202. (define (os2-graphics/open descriptor->device #!optional width height)
  203.   (if (not event-descriptor)
  204.       (begin
  205.     (set! event-descriptor (os2win-open-event-qid))
  206.     (set! event-previewer-registration
  207.           (permanently-register-input-thread-event
  208.            event-descriptor
  209.            (current-thread)
  210.            read-and-process-event))
  211.     (set! graphics-window-icon
  212.           (os2win-load-pointer HWND_DESKTOP NULLHANDLE IDI_GRAPHICS))))
  213.   (open-window descriptor->device
  214.            (if (default-object? width) 256 width)
  215.            (if (default-object? height) 256 height)))
  216.  
  217. (define (open-window descriptor->device width height)
  218.   (let ((wid (os2win-open event-descriptor "Scheme Graphics")))
  219.     (os2win-set-icon wid graphics-window-icon)
  220.     (os2win-show-cursor wid #f)
  221.     (os2win-show wid #t)
  222.     (os2win-set-size wid width height)
  223.     (pm-synchronize)
  224.     (os2win-set-state wid window-state:deactivate)
  225.     (os2win-set-state wid window-state:top)
  226.     (let ((window (make-window wid width height)))
  227.       (update-colors window)
  228.       (set-window-font! window "4.System VIO")
  229.       (let ((device (descriptor->device window)))
  230.     (os2-graphics/clear device)
  231.     (set-window/device! window device)
  232.     device))))
  233.  
  234. (define (os2-graphics/close device)
  235.   (let ((window (graphics-device/descriptor device)))
  236.     (without-interrupts
  237.      (lambda ()
  238.        (close-window window)))))
  239.  
  240. (define (os2-graphics/clear device)
  241.   (let ((window (graphics-device/descriptor device)))
  242.     (without-interrupts
  243.      (lambda ()
  244.        (let ((width (window/pel-width window))
  245.          (height (window/pel-height window)))
  246.      (os2ps-clear (window/backing-store window) 0 width 0 height)
  247.      (invalidate-rectangle device 0 width 0 height))))))
  248.  
  249. (define (os2-graphics/coordinate-limits device)
  250.   (let ((window (graphics-device/descriptor device)))
  251.     (without-interrupts
  252.      (lambda ()
  253.        (values (window/x-left window)
  254.            (window/y-bottom window)
  255.            (window/x-right window)
  256.            (window/y-top window))))))
  257.  
  258. (define (os2-graphics/device-coordinate-limits device)
  259.   (let ((window (graphics-device/descriptor device)))
  260.     (without-interrupts
  261.      (lambda ()
  262.        (values 0
  263.            0
  264.            (- (window/pel-width window) 1)
  265.            (- (window/pel-height window) 1))))))
  266.  
  267. (define (os2-graphics/drag-cursor device x y)
  268.   (let ((window (graphics-device/descriptor device)))
  269.     (without-interrupts
  270.      (lambda ()
  271.        (let ((xs (window/x-gcursor window))
  272.          (ys (window/y-gcursor window))
  273.          (xe (window/x->device window x))
  274.          (ye (window/y->device window y)))
  275.      (let ((xl (if (fix:< xs xe) xs xe))
  276.            (yl (if (fix:< ys ye) ys ye))
  277.            (xh (fix:+ (if (fix:> xs xe) xs xe) 1))
  278.            (yh (fix:+ (if (fix:> ys ye) ys ye) 1)))
  279.        (os2ps-line (window/backing-store window) xe ye)
  280.        (set-window/x-gcursor! window xe)
  281.        (set-window/y-gcursor! window ye)
  282.        (invalidate-rectangle device xl xh yl yh)))))))
  283.  
  284. (define (os2-graphics/draw-line device x-start y-start x-end y-end)
  285.   (os2-graphics/move-cursor device x-start y-start)
  286.   (os2-graphics/drag-cursor device x-end y-end))
  287.  
  288. (define (os2-graphics/draw-lines device xv yv)
  289.   (let ((window (graphics-device/descriptor device)))
  290.     (without-interrupts
  291.      (lambda ()
  292.        (let ((xv (vector-map (lambda (x) (window/x->device window x)) xv))
  293.          (yv (vector-map (lambda (y) (window/y->device window y)) yv)))
  294.      (let ((xl (fix:vector-min xv))
  295.            (yl (fix:vector-min yv))
  296.            (xh (fix:+ (fix:vector-max xv) 1))
  297.            (yh (fix:+ (fix:vector-max yv) 1)))
  298.        (os2ps-poly-line-disjoint (window/backing-store window) xv yv)
  299.        (invalidate-rectangle device xl xh yl yh)))))))
  300.  
  301. (define (os2-graphics/draw-point device x y)
  302.   ;; This sucks.  Implement a real point-drawing primitive.
  303.   (let ((window (graphics-device/descriptor device)))
  304.     (without-interrupts
  305.      (lambda ()
  306.        (let ((x (window/x->device window x))
  307.          (y (window/y->device window y)))
  308.      (os2ps-draw-point (window/backing-store window) x y)
  309.      (invalidate-rectangle device x (fix:+ x 1) y (fix:+ y 1)))))))
  310.  
  311. (define (os2-graphics/draw-text device x y string)
  312.   (let ((window (graphics-device/descriptor device))
  313.     (length (string-length string)))
  314.     (without-interrupts
  315.      (lambda ()
  316.        (let ((psid (window/backing-store window))
  317.          (metrics (window/font-metrics window))
  318.          (x (window/x->device window x))
  319.          (y (window/y->device window y)))
  320.      (os2ps-write psid
  321.               x
  322.               (fix:+ y (font-metrics/descender metrics))
  323.               string
  324.               0
  325.               length)
  326.      (invalidate-rectangle device
  327.                    x
  328.                    (fix:+ x
  329.                       (os2ps-text-width psid string 0 length))
  330.                    y
  331.                    (fix:+ y (font-metrics/height metrics))))))))
  332.  
  333. (define (os2-graphics/flush device)
  334.   (let ((window (graphics-device/descriptor device)))
  335.     (without-interrupts
  336.      (lambda ()
  337.        (let ((changes (window/changes window)))
  338.      (if changes
  339.          (begin
  340.            (os2win-invalidate (window/wid window)
  341.                   (changes/x-left changes)
  342.                   (changes/x-right changes)
  343.                   (changes/y-bottom changes)
  344.                   (changes/y-top changes))
  345.            (set-window/changes! window #f))))))))
  346.  
  347. (define (invalidate-rectangle device x-left x-right y-bottom y-top)
  348.   (let ((window (graphics-device/descriptor device)))
  349.     (if (graphics-device/buffer? device)
  350.     (let ((changes (window/changes window)))
  351.       (if (not changes)
  352.           (set-window/changes! window
  353.                    (make-changes x-left
  354.                          x-right
  355.                          y-bottom
  356.                          y-top))
  357.           (begin
  358.         (if (fix:< x-left (changes/x-left changes))
  359.             (set-changes/x-left! changes x-left))
  360.         (if (fix:> x-right (changes/x-right changes))
  361.             (set-changes/x-right! changes x-right))
  362.         (if (fix:< y-bottom (changes/y-bottom changes))
  363.             (set-changes/y-bottom! changes y-bottom))
  364.         (if (fix:> y-top (changes/y-top changes))
  365.             (set-changes/y-top! changes y-top)))))
  366.     (os2win-invalidate (window/wid window)
  367.                x-left x-right y-bottom y-top))))
  368.  
  369. (define-structure (changes (type vector)
  370.                (conc-name changes/)
  371.                (constructor make-changes))
  372.   x-left
  373.   x-right
  374.   y-bottom
  375.   y-top)
  376.  
  377. (define (os2-graphics/move-cursor device x y)
  378.   (let ((window (graphics-device/descriptor device)))
  379.     (without-interrupts
  380.      (lambda ()
  381.        (let ((x (window/x->device window x))
  382.          (y (window/y->device window y)))
  383.      (os2ps-move-graphics-cursor (window/backing-store window) x y)
  384.      (set-window/x-gcursor! window x)
  385.      (set-window/y-gcursor! window y))))))
  386.  
  387. (define (os2-graphics/reset-clip-rectangle device)
  388.   (os2ps-reset-clip-rectangle (os2-graphics-device/psid device)))
  389.  
  390. (define (os2-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
  391.   (let ((window (graphics-device/descriptor device)))
  392.     (without-interrupts
  393.      (lambda ()
  394.        (os2ps-set-clip-rectangle (window/backing-store window)
  395.                  (window/x->device window x-left)
  396.                  (window/x->device window x-right)
  397.                  (window/y->device window y-bottom)
  398.                  (window/y->device window y-top))))))
  399.  
  400. (define (os2-graphics/set-coordinate-limits device
  401.                         x-left y-bottom x-right y-top)
  402.   (let ((window (graphics-device/descriptor device)))
  403.     (without-interrupts
  404.      (lambda ()
  405.        (set-window/x-left! window x-left)
  406.        (set-window/y-bottom! window y-bottom)
  407.        (set-window/x-right! window x-right)
  408.        (set-window/y-top! window y-top)
  409.        (compute-window-slopes! window)))))
  410.  
  411. (define (os2-graphics/set-drawing-mode device mode)
  412.   (os2ps-set-mix (os2-graphics-device/psid device)
  413.          (map-drawing-mode mode)))
  414.  
  415. (define (os2-graphics/set-line-style device style)
  416.   (os2ps-set-line-type (os2-graphics-device/psid device)
  417.                (map-line-style style)))
  418.  
  419. ;;;; Color Operations
  420.  
  421. (define (os2-graphics/color? device)
  422.   (not (= 0 (os2ps-query-capability (os2-graphics-device/psid device)
  423.                     CAPS_COLOR_TABLE_SUPPORT))))
  424.  
  425. (define (os2-graphics/define-color device name color)
  426.   device
  427.   (os2/define-color name color))
  428.  
  429. (define (os2-graphics/find-color device specification)
  430.   device
  431.   (os2/find-color specification))
  432.  
  433. (define (os2-graphics/set-background-color device color)
  434.   (let ((window (graphics-device/descriptor device))
  435.     (color (->color color 'SET-BACKGROUND-COLOR)))
  436.     (without-interrupts
  437.       (lambda ()
  438.     (set-window/background-color! window color)
  439.     (update-colors window)))))
  440.  
  441. (define (os2-graphics/set-foreground-color device color)
  442.   (let ((window (graphics-device/descriptor device))
  443.     (color (->color color 'SET-FOREGROUND-COLOR)))
  444.     (without-interrupts
  445.       (lambda ()
  446.     (set-window/foreground-color! window color)
  447.     (update-colors window)))))
  448.  
  449. (define (update-colors window)
  450.   (os2ps-set-colors (window/backing-store window)
  451.             (window/foreground-color window)
  452.             (window/background-color window)))
  453.  
  454. (define (os2-graphics/image-depth device)
  455.   (let ((bitcount
  456.      (os2ps-query-capability (os2-graphics-device/psid device)
  457.                  CAPS_COLOR_BITCOUNT)))
  458.     (if (<= 1 bitcount 8)
  459.     bitcount
  460.     8)))
  461.  
  462. ;;;; Window Operations
  463.  
  464. (define (os2-graphics/window-size device)
  465.   (let ((w.h (os2win-get-size (os2-graphics-device/wid device))))
  466.     (values (car w.h)
  467.         (cdr w.h))))
  468.  
  469. (define (os2-graphics/set-window-size device width height)
  470.   (os2win-set-size (os2-graphics-device/wid device) width height))
  471.  
  472. (define (os2-graphics/window-frame-size device)
  473.   (let ((w.h (os2win-get-frame-size (os2-graphics-device/wid device))))
  474.     (values (car w.h)
  475.         (cdr w.h))))
  476.  
  477. (define (os2-graphics/window-position device)
  478.   (let ((x.y (os2win-get-pos (os2-graphics-device/wid device))))
  479.     (values (car x.y)
  480.         (cdr x.y))))
  481.  
  482. (define (os2-graphics/set-window-position device x y)
  483.   (os2win-set-pos (os2-graphics-device/wid device) x y))
  484.  
  485. (define (os2-graphics/set-window-title device title)
  486.   (os2win-set-title (os2-graphics-device/wid device) title))
  487.  
  488. (define (os2-graphics/set-font device font-specifier)
  489.   (set-window-font! (graphics-device/descriptor device) font-specifier))
  490.  
  491. (define (os2-graphics/hide-window device)
  492.   (os2win-set-state (os2-graphics-device/wid device) window-state:hide))
  493.  
  494. (define (os2-graphics/minimize-window device)
  495.   (os2win-set-state (os2-graphics-device/wid device) window-state:minimize))
  496.  
  497. (define (os2-graphics/maximize-window device)
  498.   (os2win-set-state (os2-graphics-device/wid device) window-state:maximize))
  499.  
  500. (define (os2-graphics/restore-window device)
  501.   (os2win-set-state (os2-graphics-device/wid device) window-state:restore))
  502.  
  503. (define (os2-graphics/raise-window device)
  504.   (os2win-set-state (os2-graphics-device/wid device) window-state:top))
  505.  
  506. (define (os2-graphics/lower-window device)
  507.   (os2win-set-state (os2-graphics-device/wid device) window-state:bottom))
  508.  
  509. (define (os2-graphics/activate-window device)
  510.   (os2win-set-state (os2-graphics-device/wid device) window-state:activate))
  511.  
  512. (define (os2-graphics/deactivate-window device)
  513.   (os2win-set-state (os2-graphics-device/wid device) window-state:deactivate))
  514.  
  515. (define (os2-graphics/desktop-size device)
  516.   device
  517.   (values (os2win-desktop-width) (os2win-desktop-height)))
  518.  
  519. ;;;; Color Support
  520.  
  521. (define (os2/define-color name color)
  522.   (if (not (and (color-name? name)
  523.         (not (char=? #\# (string-ref name 0)))))
  524.       (error:wrong-type-argument name "color name" 'OS2/DEFINE-COLOR))
  525.   (let ((entry (lookup-color-name name))
  526.     (color (->color color 'OS2/DEFINE-COLOR)))
  527.     (if entry
  528.     (set-cdr! entry color)
  529.     (begin
  530.       (set! color-table (cons (cons name color) color-table))
  531.       unspecific))))
  532.  
  533. (define (os2/find-color specification)
  534.   (->color specification 'OS2/FIND-COLOR))
  535.  
  536. (define (->color specification procedure)
  537.   (cond ((color? specification)
  538.      specification)
  539.     ((color-triple? specification)
  540.      (triple->color specification))
  541.     ((color-name? specification)
  542.      (name->color specification procedure))
  543.     (else
  544.      (error:wrong-type-argument specification
  545.                     "color specification"
  546.                     procedure))))
  547.  
  548. (define (color? object)
  549.   (and (exact-nonnegative-integer? object)
  550.        (< object #x1000000)))
  551.  
  552. (define (color-triple? object)
  553.   (and (list? object)
  554.        (= 3 (length object))
  555.        (for-all? object
  556.      (lambda (element)
  557.        (and (exact-nonnegative-integer? element)
  558.         (< element #x100))))))
  559.  
  560. (define (triple->color triple)
  561.   (+ (* #x10000 (car triple))
  562.      (* #x100 (cadr triple))
  563.      (caddr triple)))
  564.  
  565. (define (color-name? object)
  566.   (and (string? object)
  567.        (not (string-null? object))))
  568.  
  569. (define (name->color name procedure)
  570.   (if (char=? #\# (string-ref name 0))
  571.       (let ((color (substring->number name 1 (string-length name) 16)))
  572.     (if (not (color? color))
  573.         (error:bad-range-argument name procedure))
  574.     color)
  575.       (let ((entry (lookup-color-name name)))
  576.     (if (not entry)
  577.         (error:bad-range-argument name procedure))
  578.     (cdr entry))))
  579.  
  580. (define (lookup-color-name name)
  581.   (let loop ((entries color-table))
  582.     (and (not (null? entries))
  583.      (if (string-ci=? (caar entries) name)
  584.          (car entries)
  585.          (loop (cdr entries))))))
  586.  
  587. (define (initialize-color-table)
  588.   (set! color-table '())
  589.   (for-each (lambda (entry)
  590.           (os2/define-color (car entry) (cdr entry)))
  591.         initial-color-definitions))
  592.  
  593. (define color-table)
  594.  
  595. (define initial-color-definitions
  596.   `(("red"          255   0   0)
  597.     ("green"          0 255   0)
  598.     ("blue"           0   0 255)
  599.     ("cyan"           0 255 255)
  600.     ("magenta"      255   0 255)
  601.     ("yellow"       255 255   0)
  602.     ("black"          0   0   0)
  603.     ("dark gray"     63  63  63)
  604.     ("dark grey"     63  63  63)
  605.     ("gray"         127 127 127)
  606.     ("grey"         127 127 127)
  607.     ("light gray"   191 191 191)
  608.     ("light grey"   191 191 191)
  609.     ("white"        255 255 255)
  610.     ("purple"        127   0 127)
  611.     ("dark green"     0 127   0)
  612.     ("orange"       255 135   0)
  613.     ("pink"         255 181 197)
  614.     ("brown"        127  63   0)))
  615.  
  616. ;;;; Console Window
  617.  
  618. ;;; This and the color support really should be in a separate file.
  619.  
  620. (define (os2-console/color?)
  621.   (not (= 0 (os2ps-query-capability (os2win-ps (os2win-console-wid))
  622.                     CAPS_COLOR_TABLE_SUPPORT))))
  623.  
  624. (define (os2-console/get-font-metrics)
  625.   (let ((metrics (os2ps-get-font-metrics (os2win-ps (os2win-console-wid)))))
  626.     (values (font-metrics/width metrics)
  627.         (font-metrics/height metrics))))
  628.  
  629. (define (os2-console/set-font! font-name)
  630.   (if (not (os2ps-set-font (os2win-ps (os2win-console-wid)) 1 font-name))
  631.       (error:bad-range-argument font-name 'OS2-CONSOLE/SET-FONT!)))
  632.  
  633. (define (os2-console/set-colors! foreground background)
  634.   (let ((wid (os2win-console-wid)))
  635.     (os2ps-set-colors (os2win-ps wid)
  636.               (os2/find-color foreground)
  637.               (os2/find-color background))
  638.     (let ((w.h (os2win-get-size wid)))
  639.       (os2win-invalidate wid 0 (car w.h) 0 (cdr w.h)))))
  640.  
  641. (define (os2-console/get-pel-size)
  642.   (let ((w.h (os2win-get-size (os2win-console-wid))))
  643.     (values (car w.h)
  644.         (cdr w.h))))
  645.  
  646. (define (os2-console/set-pel-size! width height)
  647.   (os2win-set-size (os2win-console-wid) width height))
  648.  
  649. (define (os2-console/get-size)
  650.   (let ((wid (os2win-console-wid)))
  651.     (let ((w.h (os2win-get-size wid))
  652.       (metrics (os2ps-get-font-metrics (os2win-ps wid))))
  653.       (values (quotient (car w.h) (font-metrics/width metrics))
  654.           (quotient (cdr w.h) (font-metrics/height metrics))))))
  655.  
  656. (define (os2-console/set-size! width height)
  657.   (let ((metrics (os2ps-get-font-metrics (os2win-ps (os2win-console-wid)))))
  658.     (os2-console/set-pel-size! (* width (font-metrics/width metrics))
  659.                    (* height (font-metrics/height metrics)))))
  660.  
  661. (define (os2-console/get-frame-size)
  662.   (let ((w.h (os2win-get-frame-size (os2win-console-wid))))
  663.     (values (car w.h)
  664.         (cdr w.h))))
  665.  
  666. (define (os2-console/get-frame-position)
  667.   (let ((x.y (os2win-get-pos (os2win-console-wid))))
  668.     (values (car x.y)
  669.         (cdr x.y))))
  670.  
  671. (define (os2-console/set-frame-position! x y)
  672.   (os2win-set-pos (os2win-console-wid) x y))
  673.  
  674. ;;;; Miscellaneous Support
  675.  
  676. (define (set-window-font! window font-specifier)
  677.   (set-window/font-specifier! window font-specifier)
  678.   (set-window/font-metrics!
  679.    window
  680.    (let ((metrics
  681.       (os2ps-set-font (window/backing-store window) 1 font-specifier)))
  682.      (if (not metrics)
  683.      (error "Unknown font name:" font-specifier))
  684.      metrics)))
  685.  
  686. (define (fix:vector-min v)
  687.   (let ((length (vector-length v))
  688.     (min (vector-ref v 0)))
  689.     (do ((index 1 (fix:+ index 1)))
  690.     ((fix:= index length))
  691.       (if (fix:< (vector-ref v index) min)
  692.       (set! min (vector-ref v index))))
  693.     min))
  694.  
  695. (define (fix:vector-max v)
  696.   (let ((length (vector-length v))
  697.     (max (vector-ref v 0)))
  698.     (do ((index 1 (fix:+ index 1)))
  699.     ((fix:= index length))
  700.       (if (fix:> (vector-ref v index) max)
  701.       (set! max (vector-ref v index))))
  702.     max))
  703.  
  704. (define map-drawing-mode
  705.   (let ((modes
  706.      (vector FM_ZERO
  707.          FM_AND
  708.          FM_MASKSRCNOT
  709.          FM_OVERPAINT
  710.          FM_SUBTRACT
  711.          FM_LEAVEALONE
  712.          FM_XOR
  713.          FM_OR
  714.          FM_NOTMERGESRC
  715.          FM_NOTXORSRC
  716.          FM_INVERT
  717.          FM_MERGESRCNOT
  718.          FM_NOTCOPYSRC
  719.          FM_MERGENOTSRC
  720.          FM_NOTMASKSRC
  721.          FM_ONE)))
  722.     (lambda (mode)
  723.       (if (not (and (fix:fixnum? mode) (fix:<= 0 mode) (fix:< mode 16)))
  724.       (error:wrong-type-argument mode "graphics line style"
  725.                      'MAP-DRAWING-MODE))
  726.       (vector-ref modes mode))))
  727.  
  728. (define map-line-style
  729.   (let ((styles
  730.      (vector LINETYPE_SOLID
  731.          LINETYPE_SHORTDASH
  732.          LINETYPE_DOT
  733.          LINETYPE_DASHDOT
  734.          LINETYPE_DASHDOUBLEDOT
  735.          LINETYPE_LONGDASH
  736.          LINETYPE_DOUBLEDOT
  737.          LINETYPE_ALTERNATE)))
  738.     (lambda (style)
  739.       (if (not (and (fix:fixnum? style) (fix:<= 0 style) (fix:< style 8)))
  740.       (error:wrong-type-argument style "graphics line style"
  741.                      'MAP-LINE-STYLE))
  742.       (vector-ref styles style))))
  743.  
  744. ;;;; Events
  745.  
  746. (define (pm-synchronize)
  747.   (os2pm-synchronize)
  748.   (with-thread-events-blocked
  749.     (lambda () (do () ((not (read-and-process-event)))))))
  750.  
  751. (define (read-and-process-event)
  752.   (let ((event (os2win-get-event event-descriptor #f)))
  753.     (and event
  754.      (begin (process-event event) #t))))
  755.  
  756. (define (process-event event)
  757.   (without-interrupts
  758.    (lambda ()
  759.      (let ((window
  760.         (search-gc-finalizer window-finalizer
  761.           (let ((wid (event-wid event)))
  762.         (lambda (window)
  763.           (eq? (window/wid window) wid))))))
  764.        (if window
  765.        (begin
  766.          (let ((handler (vector-ref event-handlers (event-type event))))
  767.            (if handler
  768.            (handler window event)))
  769.          (maybe-queue-user-event window event)))))))
  770.  
  771. (define event-handlers (make-vector number-of-event-types #f))
  772.  
  773. (define-integrable (define-event-handler event-type handler)
  774.   (vector-set! event-handlers event-type handler))
  775.  
  776. (define-event-handler event-type:button
  777.   (lambda (window event)
  778.     (if (and (eq? button-event-type:down (button-event/type event))
  779.          (not (os2win-focus? (window/wid window))))
  780.     (os2win-activate (window/wid window)))))
  781.  
  782. (define-event-handler event-type:close
  783.   (lambda (window event)
  784.     event
  785.     (close-window window)))
  786.  
  787. (define-event-handler event-type:paint
  788.   (lambda (window event)
  789.     (os2ps-bitblt (os2win-ps (window/wid window))
  790.           (window/backing-store window)
  791.           (let ((xl (paint-event/xl event)))
  792.             (vector xl (paint-event/xh event) xl))
  793.           (let ((yl (paint-event/yl event)))
  794.             (vector yl (paint-event/yh event) yl))
  795.           ROP_SRCCOPY
  796.           BBO_OR)))
  797.  
  798. (define-event-handler event-type:resize
  799.   (lambda (window event)
  800.     (let ((width (resize-event/width event))
  801.       (height (resize-event/height event)))
  802.       (let ((old (window/backing-store window)))
  803.     (let ((bitmap (os2ps-create-bitmap old width height)))
  804.       (let ((new (os2ps-create-memory-ps)))
  805.         (os2ps-set-bitmap new bitmap)
  806.         ;; I'm worried that this will fail because the new memory PS
  807.         ;; doesn't have the correct attributes.  Maybe this will
  808.         ;; only cause trouble once we start hacking color maps.
  809.         (os2ps-bitblt new
  810.               old
  811.               (vector 0 width 0 (window/pel-width window))
  812.               (vector 0 height 0 (window/pel-height window))
  813.               ROP_SRCCOPY
  814.               BBO_IGNORE)
  815.         (os2ps-set-bitmap new #f)
  816.         (os2ps-destroy-memory-ps new))
  817.       (os2ps-destroy-bitmap (os2ps-set-bitmap old bitmap))))
  818.       (set-window/pel-width! window width)
  819.       (set-window/pel-height! window height)
  820.       (compute-window-slopes! window)
  821.       (os2win-invalidate (window/wid window) 0 width 0 height)
  822.       (set-window/changes! window #f))))
  823.  
  824. ;;;; User Events
  825.  
  826. (define (maybe-queue-user-event window event)
  827.   (if (not (fix:= 0 (fix:and (fix:lsh 1 (event-type event)) user-event-mask)))
  828.       (begin
  829.     (set-event-wid! event (window/device window))
  830.     (enqueue!/unsafe user-event-queue event))))
  831.  
  832. (define (os2-graphics/select-user-events device mask)
  833.   device
  834.   (if (not (and (exact-nonnegative-integer? mask)
  835.         (< mask (expt 2 number-of-event-types))))
  836.       (error:bad-range-argument mask 'SELECT-USER-EVENTS))
  837.   (set! user-event-mask mask)
  838.   unspecific)
  839.  
  840. (define (os2-graphics/read-user-event device)
  841.   device
  842.   (with-thread-events-blocked
  843.    (lambda ()
  844.      (let loop ()
  845.        (if (queue-empty? user-event-queue)
  846.        (begin
  847.          (if (eq? 'INPUT-AVAILABLE
  848.               (test-for-input-on-descriptor event-descriptor #t))
  849.          (read-and-process-event))
  850.          (loop))
  851.        (dequeue! user-event-queue))))))
  852.  
  853. (define (os2-graphics/read-button device)
  854.   (let ((window (graphics-device/descriptor device))
  855.     (event
  856.      (let loop ()
  857.        (let ((event (os2-graphics/read-user-event device)))
  858.          (if (and (eq? event-type:button (event-type event))
  859.               (eq? button-event-type:down (button-event/type event)))
  860.          event
  861.          (loop))))))
  862.     (values (button-event/number event)
  863.         (window/device->x window (button-event/x event))
  864.         (window/device->y window (button-event/y event))
  865.         (event-wid event))))
  866.  
  867. (define (os2-graphics/discard-events device)
  868.   device
  869.   (with-thread-events-blocked
  870.    (lambda ()
  871.      (let loop ()
  872.        (flush-queue! user-event-queue)
  873.        (if (read-and-process-event)
  874.        (loop))))))
  875.  
  876. (define (flush-queue! queue)
  877.   (without-interrupts
  878.    (lambda ()
  879.      (let loop ()
  880.        (if (not (queue-empty? queue))
  881.        (begin
  882.          (dequeue!/unsafe queue)
  883.          (loop)))))))
  884.  
  885. ;;;; Images
  886.  
  887. (define-structure (image (conc-name image/))
  888.   ps
  889.   (width #f read-only #t)
  890.   (height #f read-only #t)
  891.   colormap)
  892.  
  893. (define (os2-graphics/capture-image device x-left y-bottom x-right y-top)
  894.   (let ((window (graphics-device/descriptor device)))
  895.     (let ((x (window/x->device window x-left))
  896.       (y (window/y->device window y-bottom)))
  897.       (let ((width (+ (- (window/x->device window x-right) x) 1))
  898.         (height (+ (- (window/y->device window y-top) y) 1)))
  899.     (let ((image (image/create device width height)))
  900.       (os2ps-bitblt (image/ps (image/descriptor image))
  901.             (window/backing-store window)
  902.             (vector x (+ x width) 0)
  903.             (vector y (+ y height) 0)
  904.             ROP_SRCCOPY
  905.             BBO_OR)
  906.       image)))))
  907.  
  908. (define (os2-image/create device width height)
  909.   device
  910.   (create-image width height))
  911.  
  912. (define (create-image width height)
  913.   (let ((ps (os2ps-create-memory-ps)))
  914.     (os2ps-set-bitmap ps (os2ps-create-bitmap ps width height))
  915.     (let ((image (make-image ps width height #f)))
  916.       (add-to-gc-finalizer! image-finalizer image ps)
  917.       image)))
  918.  
  919. (define (os2-image/set-colormap image colormap)
  920.   ;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR doesn't accept a colormap
  921.   ;; argument to define how the bytes in the vector map into colors.
  922.   ;; But OS/2 needs this information in order to transform those bytes
  923.   ;; into a bitmap.  So this operation allows a colormap to be stored
  924.   ;; in the image and retrieved later.
  925.   (set-image/colormap! (image/descriptor image) colormap))
  926.  
  927. (define (os2-image/destroy image)
  928.   (destroy-image (image/descriptor image)))
  929.  
  930. (define (destroy-image image)
  931.   (if (image/ps image)
  932.       (begin
  933.     (remove-from-gc-finalizer! image-finalizer image)
  934.     (set-image/ps! image #f))))
  935.  
  936. (define (destroy-memory-ps ps)
  937.   (let ((bitmap (os2ps-set-bitmap ps #f)))
  938.     (os2ps-destroy-memory-ps ps)
  939.     (if bitmap
  940.     (os2ps-destroy-bitmap bitmap))))
  941.  
  942. (define (os2-image/width image)
  943.   (image/width (image/descriptor image)))
  944.  
  945. (define (os2-image/height image)
  946.   (image/height (image/descriptor image)))
  947.  
  948. (define (os2-image/fill-from-byte-vector image bytes)
  949.   (let ((image (image/descriptor image)))
  950.     (set-bitmap-bits
  951.      (image/ps image)
  952.      (let ((width (image/width image))
  953.        (height (image/height image)))
  954.        (make-bitmap-info width height 8
  955.              (image/colormap image)
  956.              (convert-bitmap-data width height bytes))))))
  957.  
  958. (define (convert-bitmap-data width height bytes)
  959.   ;; Convert Scheme bitmap data layout to OS/2 bitmap layout.  Scheme
  960.   ;; layout is row-major with upper-left corner at index zero with no
  961.   ;; padding.  OS/2 layout is row-major with lower-left corner at
  962.   ;; index zero and rows padded to 32-bit boundaries.  This conversion
  963.   ;; uses the OS/2 standard 8-bit-per-pixel bitmap format.
  964.   (let ((row-size (* (ceiling (/ (* 8 width) 32)) 4)))
  965.     (let ((copy (make-string (* row-size height))))
  966.       (let loop ((from 0) (to (string-length copy)))
  967.     (if (not (fix:= to 0))
  968.         (let ((from* (fix:+ from width))
  969.           (to (fix:- to row-size)))
  970.           (substring-move! bytes from from* copy to)
  971.           (loop from* to))))
  972.       copy)))
  973.  
  974. (define (os2-image/draw device x y image)
  975.   (let ((window (graphics-device/descriptor device))
  976.     (image (image/descriptor image)))
  977.     (draw-image device
  978.         (window/x->device window x)
  979.         (window/y->device window y)
  980.         image
  981.         0
  982.         0
  983.         (image/width image)
  984.         (image/height image))))
  985.  
  986. (define (os2-image/draw-subimage device x y image
  987.                  image-x image-y image-width image-height)
  988.   (let ((window (graphics-device/descriptor device))
  989.     (image (image/descriptor image)))
  990.     (draw-image device
  991.         (window/x->device window x)
  992.         (window/y->device window y)
  993.         image
  994.         image-x
  995.         ;; IMAGE-Y must be inverted because Scheme images have
  996.         ;; origin in upper left and OS/2 bitmaps have origin
  997.         ;; in lower left.
  998.         (- (image/height image) (+ image-y image-height))
  999.         image-width
  1000.         image-height)))
  1001.  
  1002. (define (draw-image device x-left y-top
  1003.             image image-x image-y image-width image-height)
  1004.   (let ((y-top (+ y-top 1)))
  1005.     (let ((x-right (+ x-left image-width))
  1006.       (y-bottom (- y-top image-height)))
  1007.       (os2ps-bitblt (os2-graphics-device/psid device)
  1008.             (image/ps image)
  1009.             (vector x-left x-right image-x)
  1010.             (vector y-bottom y-top image-y)
  1011.             ROP_SRCCOPY
  1012.             BBO_OR)
  1013.       (invalidate-rectangle device x-left x-right y-bottom y-top))))
  1014.  
  1015. ;;;; Bitmap I/O
  1016.  
  1017. ;;; This code uses the OS/2 C datatype modelling code to manipulate
  1018. ;;; OS/2 C data types which are contained in Scheme character strings.
  1019.  
  1020. (define (get-bitmap-bits psid n-bits)
  1021.   (if (not (memv n-bits '(1 4 8 24)))
  1022.       (error:bad-range-argument n-bits 'GET-BITMAP-BITS))
  1023.   (maybe-initialize-bitmaps!)
  1024.   (call-with-values (lambda () (get-bitmap-dimensions (os2ps-get-bitmap psid)))
  1025.     (lambda (width height)
  1026.       (let ((info (make-bytes:bitmap-info-2 1 n-bits))
  1027.         (data (make-bytes:bitmap-data width height 1 n-bits)))
  1028.     (let ((n (os2ps-get-bitmap-bits psid 0 height data info)))
  1029.       (if (not (= height n))
  1030.           (error "Only able to read part of bitmap data:" n height)))
  1031.     (bytes->bitmap-info info data)))))
  1032.  
  1033. (define (set-bitmap-bits psid info)
  1034.   (maybe-initialize-bitmaps!)
  1035.   (let ((height (bitmap-info/height info)))
  1036.     (call-with-values (lambda () (bitmap-info->bytes info))
  1037.       (lambda (info data)
  1038.     (let ((n (os2ps-set-bitmap-bits psid 0 height data info)))
  1039.       (if (not (= height n))
  1040.           (error "Only able to write part of bitmap data:" n height)))))))
  1041.  
  1042. (define bitmaps-initialized? #f)
  1043. (define (maybe-initialize-bitmaps!)
  1044.   (without-interrupts
  1045.    (lambda ()
  1046.      (if (not bitmaps-initialized?)
  1047.      (begin
  1048.        (initialize-c-types!)
  1049.        (define-c-type "USHORT" "unsigned short")
  1050.        (define-c-type "ULONG"  "unsigned long")
  1051.        (define-c-type "BITMAPINFOHEADER"
  1052.          '(struct ("ULONG"  "cbFix")
  1053.               ("USHORT" "cx")
  1054.               ("USHORT" "cy")
  1055.               ("USHORT" "cPlanes")
  1056.               ("USHORT" "cBitCount")))
  1057.        (define-c-type "BITMAPINFO2"
  1058.          '(struct ("ULONG"  "cbFix")
  1059.               ("ULONG"  "cx")
  1060.               ("ULONG"  "cy")
  1061.               ("USHORT" "cPlanes")
  1062.               ("USHORT" "cBitCount")
  1063.               ("ULONG"  "ulCompression")
  1064.               ("ULONG"  "cbImage")
  1065.               ("ULONG"  "cxResolution")
  1066.               ("ULONG"  "cyResolution")
  1067.               ("ULONG"  "cclrUsed")
  1068.               ("ULONG"  "cclrImportant")
  1069.               ("USHORT" "usUnits")
  1070.               ("USHORT" "usReserved")
  1071.               ("USHORT" "usRecording")
  1072.               ("USHORT" "usRendering")
  1073.               ("ULONG"  "cSize1")
  1074.               ("ULONG"  "cSize2")
  1075.               ("ULONG"  "ulColorEncoding")
  1076.               ("ULONG"  "ulIdentifier")
  1077.               ((array "ULONG" 1) "argbColor")))
  1078.        (set! get-bitmap-dimensions (make:get-bitmap-dimensions))
  1079.        (set! bytes->bitmap-info (make:bytes->bitmap-info))
  1080.        (set! bitmap-info->bytes (make:bitmap-info->bytes))
  1081.        (set! make-bytes:bitmap-info-2 (make:make-bytes:bitmap-info-2))
  1082.        (set! bitmaps-initialized? #t)
  1083.        unspecific)))))
  1084.  
  1085. (define get-bitmap-dimensions)
  1086. (define (make:get-bitmap-dimensions)
  1087.   (let ((type (lookup-c-type "BITMAPINFOHEADER")))
  1088.     (let ((width (c-number-reader type 0 "cx"))
  1089.       (height (c-number-reader type 0 "cy")))
  1090.       (lambda (bid)
  1091.     (let ((bytes (os2ps-get-bitmap-parameters bid)))
  1092.       (values (width bytes) (height bytes)))))))
  1093.  
  1094. (define bytes->bitmap-info)
  1095. (define (make:bytes->bitmap-info)
  1096.   (let ((type (lookup-c-type "BITMAPINFO2")))
  1097.     (let ((width (c-number-reader type 0 "cx"))
  1098.       (height (c-number-reader type 0 "cy"))
  1099.       (n-bits (c-number-reader type 0 "cBitCount"))
  1100.       (get-color (c-array-reader type 0 "argbColor")))
  1101.       (lambda (bytes data)
  1102.     (let ((n-bits (n-bits bytes)))
  1103.       (make-bitmap-info (width bytes)
  1104.                 (height bytes)
  1105.                 n-bits
  1106.                 (if (= n-bits 24)
  1107.                 #f
  1108.                 (make-initialized-vector (expt 2 n-bits)
  1109.                   (lambda (index)
  1110.                     (get-color bytes index))))
  1111.                 data))))))
  1112.  
  1113. (define bitmap-info->bytes)
  1114. (define (make:bitmap-info->bytes)
  1115.   (let ((type (lookup-c-type "BITMAPINFO2")))
  1116.     (let ((set-width! (c-number-writer type 0 "cx"))
  1117.       (set-height! (c-number-writer type 0 "cy"))
  1118.       (set-color! (c-array-writer type 0 "argbColor")))
  1119.       (lambda (info)
  1120.     (let ((n-bits (bitmap-info/n-bits info)))
  1121.       (let ((bytes (make-bytes:bitmap-info-2 1 n-bits)))
  1122.         (set-width! bytes (bitmap-info/width info))
  1123.         (set-height! bytes (bitmap-info/height info))
  1124.         (if (not (= n-bits 24))
  1125.         (let ((n-colors (expt 2 n-bits))
  1126.               (colormap (bitmap-info/colormap info)))
  1127.           (do ((index 0 (fix:+ index 1)))
  1128.               ((fix:= index n-colors))
  1129.             (set-color! bytes index (vector-ref colormap index)))))
  1130.         (values bytes (bitmap-info/data info))))))))
  1131.  
  1132. (define-structure (bitmap-info (conc-name bitmap-info/))
  1133.   (width #f read-only #t)
  1134.   (height #f read-only #t)
  1135.   (n-bits #f read-only #t)
  1136.   (colormap #f read-only #t)
  1137.   (data #f read-only #t))
  1138.  
  1139. (define (make-bytes:bitmap-data width height n-planes n-bits)
  1140.   (make-string (* (ceiling (/ (* n-bits width) 32)) 4 height n-planes)))
  1141.  
  1142. ;;; OS2PS-GET-BITMAP-BITS and OS2PS-SET-BITMAP-BITS both require an
  1143. ;;; argument of type BITMAPINFO2.  On input, this argument specifies
  1144. ;;; the external format of the bitmap, which is just the size and
  1145. ;;; depth of the information.  The colormap information is output from
  1146. ;;; OS2PS-GET-BITMAP-BITS and input to OS2PS-SET-BITMAP-BITS.
  1147.  
  1148. (define make-bytes:bitmap-info-2)
  1149. (define (make:make-bytes:bitmap-info-2)
  1150.   (let ((type (lookup-c-type "BITMAPINFO2")))
  1151.     (call-with-values (lambda () (select-c-type type 0 '("argbColor")))
  1152.       (lambda (rgb-type size-base)
  1153.     (let ((size-increment (c-array-type/element-spacing rgb-type))
  1154.           (set-struct-size! (c-number-writer type 0 "cbFix"))
  1155.           (set-n-planes! (c-number-writer type 0 "cPlanes"))
  1156.           (set-n-bits! (c-number-writer type 0 "cBitCount")))
  1157.       (lambda (n-planes n-bits)
  1158.         (let ((info
  1159.            (make-string (+ size-base
  1160.                    (if (= n-bits 24)
  1161.                        0
  1162.                        (* size-increment (expt 2 n-bits))))
  1163.                 (ascii->char 0))))
  1164.           (set-struct-size! info size-base)
  1165.           (set-n-planes! info n-planes)
  1166.           (set-n-bits! info n-bits)
  1167.           info)))))))