Annotation of /skeleton-edit/addprim.lAnnotation of /skeleton-edit/addprim.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; |
| 2 : | ;; addprim.l | ||
| 3 : | ;; $Revision: 1.2 $ | ||
| 4 : | ;; | ||
| 5 : | |||
| 6 : | (defun get-code-position (win) | ||
| 7 : | (let ((code-position nil) | ||
| 8 : | (save-bp-handler (get-winprop win 'button-press-handler))) | ||
| 9 : | (put-winprop win 'button-press-handler | ||
| 10 : | #'(lambda (win code x y) | ||
| 11 : | (setq code-position | ||
| 12 : | (list code | ||
| 13 : | ; tanaka 1993/9/19 | ||
| 14 : | (cond (grid (* 5 (// (+ x 2) 5)))(t x)) | ||
| 15 : | (cond (grid (* 5 (// (+ y 2) 5)))(t y)))))) | ||
| 16 : | (loop-disable-other-win win | ||
| 17 : | (function (lambda () code-position))) | ||
| 18 : | (put-winprop win 'button-press-handler save-bp-handler) | ||
| 19 : | code-position)) | ||
| 20 : | |||
| 21 : | (defun add-skeleton-element (win code x y prim element) | ||
| 22 : | (lets ((points (get-points prim)) | ||
| 23 : | (now-nth (1- (length points))) | ||
| 24 : | (lines (get-lines prim)) | ||
| 25 : | (aux-info (get-aux-info prim)) | ||
| 26 : | ; tanaka 1993/9/19 | ||
| 27 : | (x (cond (grid (* 5 (// (+ x 2) 5)))(t x))) | ||
| 28 : | (y (cond (grid (* 5 (// (+ y 2) 5)))(t y))) | ||
| 29 : | (now (list x y)) | ||
| 30 : | (number (cl:second (assq element *element-points*))) | ||
| 31 : | (newelem nil) | ||
| 32 : | (code-position nil) | ||
| 33 : | (src nil) | ||
| 34 : | (ret nil) | ||
| 35 : | (i 0)) | ||
| 36 : | |||
| 37 : | (print number) | ||
| 38 : | |||
| 39 : | ;; identify positions | ||
| 40 : | (loop | ||
| 41 : | (cond ((eq code *select-nearest*) | ||
| 42 : | (lets ((nth-nearest (nth-of-nearest-point now points)) | ||
| 43 : | (nearest (nth nth-nearest points))) | ||
| 44 : | (cond ((< (distance-points nearest now) *near-range*) | ||
| 45 : | (setq newelem (append newelem (ncons nth-nearest))) | ||
| 46 : | (unless (0= i) | ||
| 47 : | (draw-line-win win | ||
| 48 : | (first nearest) (second nearest) | ||
| 49 : | (first src) (second src)) | ||
| 50 : | (redraw-win win)) | ||
| 51 : | (setq src nearest) | ||
| 52 : | (incr i 1)) | ||
| 53 : | (t (beep win))))) | ||
| 54 : | ((and (eq code *end-mode*) (eq number 'arbitary)) | ||
| 55 : | ;;(setq points (append points (ncons now)));; eg) hira3 | ||
| 56 : | ;;(incr now-nth 1) | ||
| 57 : | ;;(setq newelem (append newelem (ncons now-nth))) | ||
| 58 : | ;;(unless (0= i) | ||
| 59 : | ;; (draw-line-win win | ||
| 60 : | ;;(first now) (second now) | ||
| 61 : | ;;(first src) (second src)) | ||
| 62 : | ;;(redraw-win win)) | ||
| 63 : | ;;(setq src now) | ||
| 64 : | (exit)) | ||
| 65 : | (t ;; *new-point-position* | ||
| 66 : | (setq points (append points (ncons now))) | ||
| 67 : | (incr now-nth 1) | ||
| 68 : | (setq newelem (append newelem (ncons now-nth))) | ||
| 69 : | (unless (0= i) | ||
| 70 : | (draw-line-win win | ||
| 71 : | (first now) (second now) | ||
| 72 : | (first src) (second src)) | ||
| 73 : | (redraw-win win)) | ||
| 74 : | (setq src now) | ||
| 75 : | (incr i 1))) | ||
| 76 : | |||
| 77 : | (if (and (fixp number) (>= i number)) (exit)) | ||
| 78 : | (setq code-position | ||
| 79 : | (if (0= i) | ||
| 80 : | (get-code-position win) | ||
| 81 : | (get-code-position:drag-lines win now (list src)))) | ||
| 82 : | (setq code (first code-position) | ||
| 83 : | now (nthcdr 1 code-position))) | ||
| 84 : | |||
| 85 : | (setq newelem (cons element (list newelem))) | ||
| 86 : | |||
| 87 : | (setq ret (cons points (cons (append lines (list newelem)) aux-info))) | ||
| 88 : | (clear-win win) | ||
| 89 : | (if grid (grid-win win)) | ||
| 90 : | (draw-skeleton-win win ret) | ||
| 91 : | (redraw-win win) | ||
| 92 : | ret)) | ||
| 93 : | |||
| 94 : | |||
| 95 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |