马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
- (defun ghostbx (inspnt cursor_type /)
- (setq picked "")
- ;; loop while user moves mouse - until point clicked
- (while (/= picked 3)
- (setq gr_read (grread t 4 cursor_type)
- picked (car gr_read)
- cursor_pnt (cadr gr_read)
- current_vecs (calc_vecs inspnt cursor_pnt)
- )
- ;; 'erase; the last vectors
- (if last_vecs
- (grvecs (list 0
- inspnt
- last_cursor_pnt
- (nth 0 last_vecs)
- (nth 1 last_vecs)
- (nth 1 last_vecs)
- (nth 2 last_vecs)
- (nth 2 last_vecs)
- (nth 3 last_vecs)
- (nth 3 last_vecs)
- (nth 4 last_vecs)
- (nth 4 last_vecs)
- (nth 0 last_vecs)
- )
- )
- )
- ;; 'draw' the current vectors
- (if current_vecs
- (grvecs (list 7
- inspnt
- cursor_pnt
- (nth 0 current_vecs)
- (nth 1 current_vecs)
- (nth 1 current_vecs)
- (nth 2 current_vecs)
- (nth 2 current_vecs)
- (nth 3 current_vecs)
- (nth 3 current_vecs)
- (nth 4 current_vecs)
- (nth 4 current_vecs)
- (nth 0 current_vecs)
- )
- )
- )
- (setq last_cursor_pnt cursor_pnt
- last_vecs (calc_vecs inspnt last_cursor_pnt)
- )
- )
- ;; end while user drags the mouse
- ;; 'erase' the remaining vectors
- (grvecs (list 0
- inspnt
- last_cursor_pnt
- (nth 0 last_vecs)
- (nth 1 last_vecs)
- (nth 1 last_vecs)
- (nth 2 last_vecs)
- (nth 2 last_vecs)
- (nth 3 last_vecs)
- (nth 3 last_vecs)
- (nth 4 last_vecs)
- (nth 4 last_vecs)
- (nth 0 last_vecs)
- )
- )
- last_vecs
- ;; return the final vectors
- )
- (defun calc_vecs (cpnt ins_pnt / p1 p2 p3 p4)
- ;; get the user angle and distance and adjust box length and width per
- ;; the functionality desired
- (cond ((= (type ins_pnt) 'list)
- (setq cang (angle cpnt ins_pnt))
- (setq box_len (distance ins_pnt cpnt))
- (setq box_wid (cond ((< box_len 900) 150.0)
- ((< box_len 3000) (* box_len 0.1667))
- (t box_wid)
- )
- )
- )
- )
- ;; return the adjusted vectors accordingly
- (list (setq p1 cpnt)
- (setq p2 (polar p1 cang box_len))
- (setq p3 (polar p2 (+ cang (* 0.5 pi)) box_wid))
- (setq p4 (polar p3 (- cang pi) box_len))
- (setq p5 p1)
- )
- )
- ; EOF
- ;;; setup to test the code
- (setq inspnt (getpoint "\nSelect first point: "))
- (setq pntlst (ghostbx inspnt 4)) ; run the test
|