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 >
Lisp/Scheme  |  1995-04-12  |  7KB  |  198 lines
  1. ;;; -*- Syntax: Common-Lisp; Mode: LISP; Package: CME; Base: 10 -*-
  2.  
  3. (in-package "CME")
  4.  
  5.  
  6. #|
  7. (user::maybe-compile-file-load '("~/curve-patch.lisp"))
  8. |#
  9.  
  10. #|
  11.  
  12. (defvar *curve-draw-vertex-radius* 3.0)
  13.  
  14. ;;; u v are raw window coords
  15. (defmethod draw-vertex ((self basic-curve) drawing-context u v)
  16.   (raw-fill-circle drawing-context u v *curve-draw-vertex-radius*))
  17.  
  18. (defmethod draw-vertex-selection-box
  19.     ((self basic-curve) visibility vertex)
  20.   (map-over-active-views (self view window)
  21.       (when (exposed-p window)
  22.     (bind-vector-elements (u v)
  23.         (vertex-transform vertex (object-to-window-transform self view))
  24.       (when u
  25.         (with-slots (vertices-visible-p open-for-vertex-modification) self
  26.           (fill-circle window u v *curve-draw-vertex-radius*
  27.                :alu (if (and open-for-vertex-modification vertices-visible-p)
  28.                     (draw-select-alu window visibility)
  29.                     (draw-and-select-alu window (not visibility)))
  30.                :transform nil)))))))
  31. |#
  32.  
  33.  
  34.  
  35. (defun showarr (arr num)
  36.   (format t "~%~d: " num)
  37.   (dotimes (i num)
  38.      (format t " ~d" (aref arr i)))
  39.   (format t "~%")
  40.   arr)
  41.  
  42.     
  43. #|
  44.  
  45. (defmethod draw-on-view-internal ((self basic-curve) view drawing-context)
  46.   (with-slot-values ( vertices last-selected-handle closed-p fill-p
  47.                    OPEN-FOR-VERTEX-MODIFICATION VERTICES-VISIBLE-P
  48.                    ) self
  49.     (declare (type-reduce number fixnum))
  50.     (let* ((nverts (length vertices))
  51.        (vertices (sys:underlying-simple-vector vertices))
  52.        ;;(2d-to-window (2d-to-window-matrix view))
  53.        ;;(3d-to-2d (view-transform view self))
  54.        ;; *curve-incremental-update-move-modes* = NIL because of inability to erase in X11
  55.        (incremental-update-p (memq (move-mode self) *curve-incremental-update-move-modes*))
  56.        (vertex-num (vertex-num self last-selected-handle))
  57.        (start-index (if incremental-update-p
  58.                 vertex-num
  59.                 (if closed-p 0 1) ))
  60.        (start-last-index (if closed-p
  61.                  (mod (1- start-index) nverts)
  62.                  (max* 0 (1- start-index))))
  63.        (end-index (if incremental-update-p
  64.               (if closed-p
  65.                   (1+ vertex-num)
  66.                   (min* (1+ vertex-num) (1- nverts))) 
  67.               (1- nverts)))
  68.        (transform-list (object-to-window-transform self view))
  69.        (draw-vertices (and open-for-vertex-modification vertices-visible-p)) )
  70.       (declare (fixnum nverts start-index start-last-index end-index ))
  71.       (declare (simple-vector vertices))
  72.       (cond ((= nverts 1)
  73.          (bind-vector-elements (u v)
  74.          (vertex-transform (aref vertices 0) transform-list
  75.                    *draw-on-view-internal-basic-curve-tmp-vector* )
  76.            (dc-draw-line drawing-context (- u 2.0) v (+ u 2.0) v)
  77.            (dc-draw-line drawing-context u (- v 2.0) u (+ v 2.0))))
  78.  
  79.         ((> nverts 1)
  80.          (with-drawing-context-color (drawing-context (get-object-drawing-color self view))
  81.            (let ((c-arr *tmp-array*)
  82.              (c-arr-i 0))
  83.          (declare (type (simple-array single-float (*)) c-arr ))
  84.          (declare (fixnum  c-arr-i))
  85.          ;; remember that bind-vector-elements executes its body
  86.          ;; ONLY when the projection succeeds.
  87.          (bind-vector-elements (u v)
  88.              (vertex-transform (aref vertices start-last-index) transform-list
  89.                        *draw-on-view-internal-basic-curve-tmp-vector* )
  90.            (setf (aref c-arr 0) u
  91.              (aref c-arr 1) v
  92.              c-arr-i 2)
  93.            (when draw-vertices
  94.              (draw-vertex-at-uv self drawing-context u v )))
  95.            
  96.          (loop for i fixnum from start-index;; (mod (1+ start-last-index) nverts)
  97.              to end-index
  98.                for vert = (aref vertices i) ;(mod i nverts)
  99.                do (bind-vector-elements (u v)
  100.                   (vertex-transform vert transform-list
  101.                         *draw-on-view-internal-basic-curve-tmp-vector* )   
  102.                 (setf (aref c-arr c-arr-i) u
  103.                   (aref c-arr (1+ c-arr-i)) v
  104.                   c-arr-i (+ c-arr-i 2))
  105.                 (when draw-vertices (draw-vertex-at-uv self drawing-context u v)
  106.                   ))
  107.                finally (when (and closed-p fill-p)
  108.                  (if (or (listp fill-p) (numberp fill-p))
  109.                      (ic::with-drawing-context-stipple (drawing-context fill-p)
  110.                        (ic::raw-fill-polygon drawing-context c-arr (ash c-arr-i -1)))
  111.                      (ic::raw-fill-polygon drawing-context c-arr (ash c-arr-i -1))))
  112.  
  113.                #|  (when (>= c-arr-i 2)
  114.                  ;; Patch around apparent bug in X11R5 which causes a wierd triangle to
  115.                  ;; drawn instead on last line segment.
  116.                  ;; Repeating the last point seems to fix the problem
  117.                  ;; This bug fix should really propagate into dc-draw-lines or deeper.
  118.                  (loop for i fixnum from c-arr-i repeat 2
  119.                        do (setf (aref c-arr i) (aref c-arr (- i 2))))
  120.                  (incf c-arr-i 2)) |#
  121.                ;; above bug handling moved to dc-draw-lines
  122.                ;;(dc-draw-lines drawing-context c-arr (ash c-arr-i -1))
  123.                (draw-fat-lines drawing-context c-arr (ash c-arr-i -1))
  124.                ))))))))
  125. |#
  126.  
  127. (defvar *line-drawing-radius* 0.0)
  128. (defvar *fatline-tmparray* (make-array 8 :element-type 'single-float))
  129.  
  130. (defun draw-fat-line (context x1 y1 x2 y2 &optional (radius *line-drawing-radius*))
  131.    (if (zerop radius)
  132.        (dc-draw-line context x1 y1 x2 y2)
  133.      (let* ((dx (- x2 x1))
  134.         (dy (- y2 y1))
  135.         (len (sqrt (+ (* dx dx) (* dy dy)))))
  136.        (unless (zerop len)
  137.        (let ((sin (* dx (/ radius len)))
  138.          (cos (* dy (/ radius len)))
  139.          (arr *fatline-tmparray*))
  140.          (setf (aref arr 0) (+ x1 cos))
  141.          (setf (aref arr 1) (- y1 sin))
  142.          (setf (aref arr 2) (- x1 cos))
  143.          (setf (aref arr 3) (+ y1 sin))
  144.          (setf (aref arr 4) (- x2 cos))
  145.          (setf (aref arr 5) (+ y2 sin))
  146.          (setf (aref arr 6) (+ x2 cos))
  147.          (setf (aref arr 7) (- y2 sin))
  148.          (ic::raw-fill-polygon context arr 4 xw::convex))))))
  149.  
  150.  
  151. (defun draw-fat-lines (context arr npoints &optional (radius *line-drawing-radius*))
  152.   (if (zerop radius)
  153.       (dc-draw-lines context arr npoints)
  154.     (dotimes (i (- npoints 1))
  155.        (let ((index (* 2 i)))
  156.      (draw-fat-line context
  157.             (aref arr index)
  158.             (aref arr (+ index 1))
  159.             (aref arr (+ index 2))
  160.             (aref arr (+ index 3))
  161.             radius)))))
  162.  
  163. (defun flush-display (pane)
  164.   (xw::xflush (xw::xdisplay pane))
  165. )
  166.  
  167.  
  168. (defun new-draw-line (pane x1 y1 x2 y2 radius)
  169.   (let* ((tmatrix (image-to-window-transform (get-view pane)))
  170.          (vec1 (coordinate-vector x1 y1 0))
  171.          (vec2 (coordinate-vector x2 y2 0))
  172.          (rvec1 (transform-vector tmatrix vec1))
  173.          (rvec2 (transform-vector tmatrix vec2))
  174.          (wx1 (aref rvec1 0))
  175.          (wy1 (aref rvec1 1)) 
  176.          (wx2 (aref rvec2 0))
  177.          (wy2 (aref rvec2 1))) 
  178.          (draw-fat-line (ic::get-view-drawing-context 
  179.                             (get-view pane)) wx1 wy1 wx2 wy2 radius)
  180.          (flush-display pane)))
  181.  
  182.  
  183. (defun new-draw-point (pane x y radius)
  184.   (let* ((tmatrix (image-to-window-transform (get-view pane)))
  185.          (vec (coordinate-vector x y 0))
  186.          (rvec (transform-vector tmatrix vec))
  187.          (wx (coerce (aref rvec 0) 'double-float))
  188.          (wy (coerce (aref rvec 1) 'double-float)) 
  189.          (rad (coerce radius 'double-float))
  190.          (context (ic::get-view-drawing-context (get-view pane))))
  191.          (raw-fill-circle context wx wy rad)
  192.          (flush-display pane)))
  193.  
  194. (defun set-ior-alu (pane)
  195.    (setf::2.ic.pane-default-alu *default-ior-alu* pane)
  196. )
  197.  
  198.