home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / demo / beziertest.l < prev    next >
Encoding:
Text File  |  1990-05-01  |  2.7 KB  |  82 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; CLX Bezier Spline Extension demo program
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package :xlib)
  22.  
  23. (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile"))
  24.   ;; Display the part picture in /extensions/test/datafile
  25.   (let* ((display (open-display host))
  26.      (width 800)
  27.      (height 800)
  28.      (screen (display-default-screen display))
  29.      (black (screen-black-pixel screen))
  30.      (white (screen-white-pixel screen))
  31.      (win (create-window
  32.         :parent (screen-root screen)
  33.         :background black
  34.         :border white
  35.         :border-width 1
  36.         :colormap (screen-default-colormap screen)
  37.         :bit-gravity :center
  38.         :event-mask '(:exposure :key-press)
  39.         :x 20 :y 20
  40.         :width width :height height))
  41.      (gc (create-gcontext
  42.            :drawable win
  43.            :background black
  44.            :foreground white))
  45.      (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16))
  46.      (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16)))
  47.     ;; Read the data
  48.     (with-open-file (stream pathname)
  49.       (loop 
  50.     (case (read-char stream nil :eof)
  51.       (#\l (dotimes (i 4) (vector-push-extend (read stream) lines)))
  52.       (#\b (dotimes (i 8) (vector-push-extend (read stream) curves)))
  53.       ((#\space #\newline #\tab))
  54.       (otherwise (return)))))
  55.     ;; The data points were created to fit in a 2048x2048 square,
  56.     ;; this means scale_factor will always be small enough so that
  57.     ;; we don't need to worry about overflows.
  58.     (let ((factor (ash (min width height) 5)))
  59.       (dotimes (i (length lines))
  60.     (setf (svref lines i)
  61.           (ash (* (svref lines i) factor) -16)))
  62.       (dotimes (i (length curves))
  63.     (setf (svref curves i)
  64.           (ash (* (svref curves i) factor) -16))))
  65.     
  66.     (map-window win)                ; Map the window
  67.     ;; Handle events
  68.     (unwind-protect
  69.     (loop
  70.       (event-case (display :force-output-p t)
  71.         (exposure  ;; Come here on exposure events
  72.           (window count)
  73.           (when (zerop count) ;; Ignore all but the last exposure event
  74.         (clear-area window)
  75.         (draw-segments win gc lines)
  76.         (draw-curves win gc curves)
  77.         (draw-glyphs win gc 10 10 "Press any key to exit")
  78.         ;; Returning non-nil causes event-case to exit
  79.         t))
  80.         (key-press () (return-from bezier-test t))))
  81.       (close-display display))))
  82.