View of /lisp/tools/addprim.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; addprim.l
;; $Revision: 1.3 $
;; 

(defun get-code-position (win)
  (let ((code-position nil)
	(save-bp-handler (get-winprop win 'button-press-handler)))
    (put-winprop win 'button-press-handler 
		 #'(lambda (win code x y)
		     (setq code-position 
			   (list code 
; tanaka 1993/9/19				 
				 (cond (grid (* 5 (// (+ x 2) 5)))(t x))
				 (cond (grid (* 5 (// (+ y 2) 5)))(t y))))))
    (loop-disable-other-win win 
			    (function (lambda () code-position)))
    (put-winprop win 'button-press-handler save-bp-handler)
    code-position))

(defun add-skeleton-element (win code x y prim element)
  (lets ((points   (get-points prim))
	 (now-nth  (1- (length points)))
	 (lines    (get-lines  prim))
         (aux-info (get-aux-info prim))
; tanaka 1993/9/19
	 (x (cond (grid (* 5 (// (+ x 2) 5)))(t x)))
	 (y (cond (grid (* 5 (// (+ y 2) 5)))(t y)))
	 (now      (list x y))
	 (number   (cl:second (assq element *element-points*)))
	 (newelem  nil)
	 (code-position nil)
	 (src nil)
	 (ret nil)
	 (i 0))

    (print number)

    ;; identify positions
    (loop 
     (cond ((eq code *select-nearest*)
	    (lets ((nth-nearest (nth-of-nearest-point now points))
		   (nearest (nth nth-nearest points)))
	      (cond ((< (distance-points nearest now) *near-range*)
		     (setq newelem (append newelem (ncons nth-nearest)))
		     (unless (0= i) 
		       (draw-line-win win 
				      (first nearest) (second nearest)
				      (first src) (second src))
		       (redraw-win win))
		     (setq src nearest)
		     (incr i 1))
		    (t (beep win)))))
	   ((and (eq code *end-mode*) (eq number 'arbitary))
	    ;;(setq points (append points (ncons now)));; eg) hira3 
	    ;;(incr now-nth 1)
	    ;;(setq newelem (append newelem (ncons now-nth)))
	    ;;(unless (0= i)
	    ;;  (draw-line-win win 
	    ;;(first now) (second now)
	    ;;(first src) (second src))
	    ;;(redraw-win win))
	    ;;(setq src now)
	    (exit))
	   (t ;; *new-point-position*
	    (setq points (append points (ncons now)))
	    (incr now-nth 1)
	    (setq newelem (append newelem (ncons now-nth)))
	    (unless (0= i)
	      (draw-line-win win 
			     (first now) (second now)
			     (first src) (second src))
	      (redraw-win win))
	    (setq src now)
	    (incr i 1)))

     (if (and (fixp number) (>= i number)) (exit))
     (setq code-position 
	   (if (0= i)
	       (get-code-position win)
	       (get-code-position:drag-lines win now (list src))))
     (setq code (first code-position)
	   now  (nthcdr 1 code-position)))
    
    (setq newelem (cons element (list newelem)))

    (setq ret (cons points (cons (append lines (list newelem)) aux-info)))
    (clear-win win)
    (if grid (grid-win win))
    (draw-skeleton-win win ret)
    (redraw-win win)
    ret))