View of /skeleton-edit/addhira.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; addhira.l
;; $Revision: 1.1 $
;;

(defun make-hira-element-long (win code x y prim)
  (lets ((ret nil)
	 (points   (get-points prim))
	 (lines    (get-lines  prim))
	 (aux-info (get-aux-info prim))
	 (now (list x y))
	 (newposition nil))
    (if lines
	(lets ((nth-nearest-elem (nth-of-nearest-element now points lines))
	       (nearest-elem (nth nth-nearest-elem lines)))
	  (comment print (list 'nearest-elem nearest-elem))
	  (comment print (list 'distance (distance-point-element
				  now points nearest-elem)
		       *near-range*))
	  (cond ((and (< (distance-point-element now points nearest-elem)
			 *near-range*)
		      (eq (cadr (assq (first nearest-elem) *element-points*))
			  'arbitary))
		 (lets ((elempoints (second nearest-elem))
			(head (nth (first elempoints) points))
			(tail (nth (car (last elempoints)) points))
			(to-head (distance-points now head))
			(to-tail (distance-points now tail))
			(new-pnum -1))
		   
		   (setq newposition 
			 (get-position:drag-lines 
			  win now 
			  (ncons (if (< to-head to-tail) head tail))
			  *end-by-release*))
		   (setq points (append points (ncons newposition)))
		   (setq new-pnum (1- (length points)))
		   (setf (second nearest-elem)
			 (if (< to-head to-tail)
			     (cons new-pnum elempoints)
			   (append elempoints (ncons new-pnum))))
		   (let ((hira-w (get-info nearest-elem 'hirawidth)))
		     (cond ((null hira-w)
			    (put-info nearest-elem 'hirawidth 
				      (make-list (length (second nearest-elem))
						 *default-hirawidth*)))
			   ((< to-head to-tail)
			    (put-info nearest-elem 'hirawidth
				      (cons *default-hirawidth* hira-w)))
			   (t
			    (put-info 
			     nearest-elem 'hirawidth
			     (append hira-w
				     (ncons *default-hirawidth*))))))))
		(t (beep win))))
      (beep win))
    (setq ret (shapeup-skeleton (cons points (cons lines aux-info))))
    (clear-win win)
    (if grid (grid-win win))
    (draw-skeleton-win win ret)
    (redraw-win win)
    ret))

(defun make-hira-element-short (win code x y prim)
  (lets ((ret nil)
	 (points   (get-points prim))
	 (lines    (get-lines  prim))
	 (aux-info (get-aux-info prim))
	 (now (list x y))
	 (newposition nil))
    (if lines
	(lets ((nth-nearest-elem (nth-of-nearest-element now points lines))
	       (nearest-elem (nth nth-nearest-elem lines)))
	  (cond ((and (< (distance-point-element now points nearest-elem)
			 *near-range*)
		      (eq (cadr (assq (first nearest-elem) *element-points*))
			  'arbitary))
		 (lets ((elempoints (second nearest-elem))
			(head (nth (first elempoints) points))
			(tail (nth (car (last elempoints)) points))
			(to-head (distance-points now head))
			(to-tail (distance-points now tail))
			(new-pnum -1))

		   (setf (second nearest-elem)
			 (if (< to-head to-tail)
			     (cdr elempoints)
			   (reverse (cdr (reverse elempoints)))))

		   (let ((hira-w (get-info nearest-elem 'hirawidth)))
		     (cond ((null hira-w)
			    (put-info nearest-elem 'hirawidth 
				      (make-list (length (second nearest-elem))
						 *default-hirawidth*)))
			   ((< to-head to-tail)
			    (put-info nearest-elem 'hirawidth (cdr hira-w)))
			   (t
			    (put-info 
			     nearest-elem 'hirawidth
			     (reverse (cdr (reverse hira-w)))))))))
		(t (beep win))))
      (beep win))
    (setq ret (shapeup-skeleton (cons points (cons lines aux-info))))
    (clear-win win)
    (if grid (grid-win win))
    (draw-skeleton-win win ret)
    (redraw-win win)
    ret))