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