home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
vis-ftp.cs.umass.edu
/
vis-ftp.cs.umass.edu.tar
/
vis-ftp.cs.umass.edu
/
pub
/
Software
/
ASCENDER
/
ascendMar8.tar
/
UMass
/
BuildingFinder
/
Lisp
/
fat-lines-patch.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1995-04-12
|
7KB
|
198 lines
;;; -*- Syntax: Common-Lisp; Mode: LISP; Package: CME; Base: 10 -*-
(in-package "CME")
#|
(user::maybe-compile-file-load '("~/curve-patch.lisp"))
|#
#|
(defvar *curve-draw-vertex-radius* 3.0)
;;; u v are raw window coords
(defmethod draw-vertex ((self basic-curve) drawing-context u v)
(raw-fill-circle drawing-context u v *curve-draw-vertex-radius*))
(defmethod draw-vertex-selection-box
((self basic-curve) visibility vertex)
(map-over-active-views (self view window)
(when (exposed-p window)
(bind-vector-elements (u v)
(vertex-transform vertex (object-to-window-transform self view))
(when u
(with-slots (vertices-visible-p open-for-vertex-modification) self
(fill-circle window u v *curve-draw-vertex-radius*
:alu (if (and open-for-vertex-modification vertices-visible-p)
(draw-select-alu window visibility)
(draw-and-select-alu window (not visibility)))
:transform nil)))))))
|#
(defun showarr (arr num)
(format t "~%~d: " num)
(dotimes (i num)
(format t " ~d" (aref arr i)))
(format t "~%")
arr)
#|
(defmethod draw-on-view-internal ((self basic-curve) view drawing-context)
(with-slot-values ( vertices last-selected-handle closed-p fill-p
OPEN-FOR-VERTEX-MODIFICATION VERTICES-VISIBLE-P
) self
(declare (type-reduce number fixnum))
(let* ((nverts (length vertices))
(vertices (sys:underlying-simple-vector vertices))
;;(2d-to-window (2d-to-window-matrix view))
;;(3d-to-2d (view-transform view self))
;; *curve-incremental-update-move-modes* = NIL because of inability to erase in X11
(incremental-update-p (memq (move-mode self) *curve-incremental-update-move-modes*))
(vertex-num (vertex-num self last-selected-handle))
(start-index (if incremental-update-p
vertex-num
(if closed-p 0 1) ))
(start-last-index (if closed-p
(mod (1- start-index) nverts)
(max* 0 (1- start-index))))
(end-index (if incremental-update-p
(if closed-p
(1+ vertex-num)
(min* (1+ vertex-num) (1- nverts)))
(1- nverts)))
(transform-list (object-to-window-transform self view))
(draw-vertices (and open-for-vertex-modification vertices-visible-p)) )
(declare (fixnum nverts start-index start-last-index end-index ))
(declare (simple-vector vertices))
(cond ((= nverts 1)
(bind-vector-elements (u v)
(vertex-transform (aref vertices 0) transform-list
*draw-on-view-internal-basic-curve-tmp-vector* )
(dc-draw-line drawing-context (- u 2.0) v (+ u 2.0) v)
(dc-draw-line drawing-context u (- v 2.0) u (+ v 2.0))))
((> nverts 1)
(with-drawing-context-color (drawing-context (get-object-drawing-color self view))
(let ((c-arr *tmp-array*)
(c-arr-i 0))
(declare (type (simple-array single-float (*)) c-arr ))
(declare (fixnum c-arr-i))
;; remember that bind-vector-elements executes its body
;; ONLY when the projection succeeds.
(bind-vector-elements (u v)
(vertex-transform (aref vertices start-last-index) transform-list
*draw-on-view-internal-basic-curve-tmp-vector* )
(setf (aref c-arr 0) u
(aref c-arr 1) v
c-arr-i 2)
(when draw-vertices
(draw-vertex-at-uv self drawing-context u v )))
(loop for i fixnum from start-index;; (mod (1+ start-last-index) nverts)
to end-index
for vert = (aref vertices i) ;(mod i nverts)
do (bind-vector-elements (u v)
(vertex-transform vert transform-list
*draw-on-view-internal-basic-curve-tmp-vector* )
(setf (aref c-arr c-arr-i) u
(aref c-arr (1+ c-arr-i)) v
c-arr-i (+ c-arr-i 2))
(when draw-vertices (draw-vertex-at-uv self drawing-context u v)
))
finally (when (and closed-p fill-p)
(if (or (listp fill-p) (numberp fill-p))
(ic::with-drawing-context-stipple (drawing-context fill-p)
(ic::raw-fill-polygon drawing-context c-arr (ash c-arr-i -1)))
(ic::raw-fill-polygon drawing-context c-arr (ash c-arr-i -1))))
#| (when (>= c-arr-i 2)
;; Patch around apparent bug in X11R5 which causes a wierd triangle to
;; drawn instead on last line segment.
;; Repeating the last point seems to fix the problem
;; This bug fix should really propagate into dc-draw-lines or deeper.
(loop for i fixnum from c-arr-i repeat 2
do (setf (aref c-arr i) (aref c-arr (- i 2))))
(incf c-arr-i 2)) |#
;; above bug handling moved to dc-draw-lines
;;(dc-draw-lines drawing-context c-arr (ash c-arr-i -1))
(draw-fat-lines drawing-context c-arr (ash c-arr-i -1))
))))))))
|#
(defvar *line-drawing-radius* 0.0)
(defvar *fatline-tmparray* (make-array 8 :element-type 'single-float))
(defun draw-fat-line (context x1 y1 x2 y2 &optional (radius *line-drawing-radius*))
(if (zerop radius)
(dc-draw-line context x1 y1 x2 y2)
(let* ((dx (- x2 x1))
(dy (- y2 y1))
(len (sqrt (+ (* dx dx) (* dy dy)))))
(unless (zerop len)
(let ((sin (* dx (/ radius len)))
(cos (* dy (/ radius len)))
(arr *fatline-tmparray*))
(setf (aref arr 0) (+ x1 cos))
(setf (aref arr 1) (- y1 sin))
(setf (aref arr 2) (- x1 cos))
(setf (aref arr 3) (+ y1 sin))
(setf (aref arr 4) (- x2 cos))
(setf (aref arr 5) (+ y2 sin))
(setf (aref arr 6) (+ x2 cos))
(setf (aref arr 7) (- y2 sin))
(ic::raw-fill-polygon context arr 4 xw::convex))))))
(defun draw-fat-lines (context arr npoints &optional (radius *line-drawing-radius*))
(if (zerop radius)
(dc-draw-lines context arr npoints)
(dotimes (i (- npoints 1))
(let ((index (* 2 i)))
(draw-fat-line context
(aref arr index)
(aref arr (+ index 1))
(aref arr (+ index 2))
(aref arr (+ index 3))
radius)))))
(defun flush-display (pane)
(xw::xflush (xw::xdisplay pane))
)
(defun new-draw-line (pane x1 y1 x2 y2 radius)
(let* ((tmatrix (image-to-window-transform (get-view pane)))
(vec1 (coordinate-vector x1 y1 0))
(vec2 (coordinate-vector x2 y2 0))
(rvec1 (transform-vector tmatrix vec1))
(rvec2 (transform-vector tmatrix vec2))
(wx1 (aref rvec1 0))
(wy1 (aref rvec1 1))
(wx2 (aref rvec2 0))
(wy2 (aref rvec2 1)))
(draw-fat-line (ic::get-view-drawing-context
(get-view pane)) wx1 wy1 wx2 wy2 radius)
(flush-display pane)))
(defun new-draw-point (pane x y radius)
(let* ((tmatrix (image-to-window-transform (get-view pane)))
(vec (coordinate-vector x y 0))
(rvec (transform-vector tmatrix vec))
(wx (coerce (aref rvec 0) 'double-float))
(wy (coerce (aref rvec 1) 'double-float))
(rad (coerce radius 'double-float))
(context (ic::get-view-drawing-context (get-view pane))))
(raw-fill-circle context wx wy rad)
(flush-display pane)))
(defun set-ior-alu (pane)
(setf::2.ic.pane-default-alu *default-ior-alu* pane)
)