Annotation of /skeleton-edit/addhira.lAnnotation of /skeleton-edit/addhira.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; |
| 2 : | ;; addhira.l | ||
| 3 : | ;; $Revision: 1.2 $ | ||
| 4 : | ;; | ||
| 5 : | |||
| 6 : | (defun make-hira-element-long (win code x y prim) | ||
| 7 : | (lets ((ret nil) | ||
| 8 : | (points (get-points prim)) | ||
| 9 : | (lines (get-lines prim)) | ||
| 10 : | (aux-info (get-aux-info prim)) | ||
| 11 : | (now (list x y)) | ||
| 12 : | (newposition nil)) | ||
| 13 : | (if lines | ||
| 14 : | (lets ((nth-nearest-elem (nth-of-nearest-element now points lines)) | ||
| 15 : | (nearest-elem (nth nth-nearest-elem lines))) | ||
| 16 : | (comment print (list 'nearest-elem nearest-elem)) | ||
| 17 : | (comment print (list 'distance (distance-point-element | ||
| 18 : | now points nearest-elem) | ||
| 19 : | *near-range*)) | ||
| 20 : | (cond ((and (< (distance-point-element now points nearest-elem) | ||
| 21 : | *near-range*) | ||
| 22 : | (eq (cadr (assq (first nearest-elem) *element-points*)) | ||
| 23 : | 'arbitary)) | ||
| 24 : | (lets ((elempoints (second nearest-elem)) | ||
| 25 : | (head (nth (first elempoints) points)) | ||
| 26 : | (tail (nth (car (last elempoints)) points)) | ||
| 27 : | (to-head (distance-points now head)) | ||
| 28 : | (to-tail (distance-points now tail)) | ||
| 29 : | (new-pnum -1)) | ||
| 30 : | |||
| 31 : | (setq newposition | ||
| 32 : | (get-position:drag-lines | ||
| 33 : | win now | ||
| 34 : | (ncons (if (< to-head to-tail) head tail)) | ||
| 35 : | *end-by-release*)) | ||
| 36 : | (setq points (append points (ncons newposition))) | ||
| 37 : | (setq new-pnum (1- (length points))) | ||
| 38 : | (setf (second nearest-elem) | ||
| 39 : | (if (< to-head to-tail) | ||
| 40 : | (cons new-pnum elempoints) | ||
| 41 : | (append elempoints (ncons new-pnum)))) | ||
| 42 : | (let ((hira-w (get-info nearest-elem 'hirawidth))) | ||
| 43 : | (cond ((null hira-w) | ||
| 44 : | (put-info nearest-elem 'hirawidth | ||
| 45 : | (make-list (length (second nearest-elem)) | ||
| 46 : | *default-hirawidth*))) | ||
| 47 : | ((< to-head to-tail) | ||
| 48 : | (put-info nearest-elem 'hirawidth | ||
| 49 : | (cons *default-hirawidth* hira-w))) | ||
| 50 : | (t | ||
| 51 : | (put-info | ||
| 52 : | nearest-elem 'hirawidth | ||
| 53 : | (append hira-w | ||
| 54 : | (ncons *default-hirawidth*)))))))) | ||
| 55 : | (t (beep win)))) | ||
| 56 : | (beep win)) | ||
| 57 : | (setq ret (shapeup-skeleton (cons points (cons lines aux-info)))) | ||
| 58 : | (clear-win win) | ||
| 59 : | (if grid (grid-win win)) | ||
| 60 : | (draw-skeleton-win win ret) | ||
| 61 : | (redraw-win win) | ||
| 62 : | ret)) | ||
| 63 : | |||
| 64 : | (defun make-hira-element-short (win code x y prim) | ||
| 65 : | (lets ((ret nil) | ||
| 66 : | (points (get-points prim)) | ||
| 67 : | (lines (get-lines prim)) | ||
| 68 : | (aux-info (get-aux-info prim)) | ||
| 69 : | (now (list x y)) | ||
| 70 : | (newposition nil)) | ||
| 71 : | (if lines | ||
| 72 : | (lets ((nth-nearest-elem (nth-of-nearest-element now points lines)) | ||
| 73 : | (nearest-elem (nth nth-nearest-elem lines))) | ||
| 74 : | (cond ((and (< (distance-point-element now points nearest-elem) | ||
| 75 : | *near-range*) | ||
| 76 : | (eq (cadr (assq (first nearest-elem) *element-points*)) | ||
| 77 : | 'arbitary)) | ||
| 78 : | (lets ((elempoints (second nearest-elem)) | ||
| 79 : | (head (nth (first elempoints) points)) | ||
| 80 : | (tail (nth (car (last elempoints)) points)) | ||
| 81 : | (to-head (distance-points now head)) | ||
| 82 : | (to-tail (distance-points now tail)) | ||
| 83 : | (new-pnum -1)) | ||
| 84 : | |||
| 85 : | (setf (second nearest-elem) | ||
| 86 : | (if (< to-head to-tail) | ||
| 87 : | (cdr elempoints) | ||
| 88 : | (reverse (cdr (reverse elempoints))))) | ||
| 89 : | |||
| 90 : | (let ((hira-w (get-info nearest-elem 'hirawidth))) | ||
| 91 : | (cond ((null hira-w) | ||
| 92 : | (put-info nearest-elem 'hirawidth | ||
| 93 : | (make-list (length (second nearest-elem)) | ||
| 94 : | *default-hirawidth*))) | ||
| 95 : | ((< to-head to-tail) | ||
| 96 : | (put-info nearest-elem 'hirawidth (cdr hira-w))) | ||
| 97 : | (t | ||
| 98 : | (put-info | ||
| 99 : | nearest-elem 'hirawidth | ||
| 100 : | (reverse (cdr (reverse hira-w))))))))) | ||
| 101 : | (t (beep win)))) | ||
| 102 : | (beep win)) | ||
| 103 : | (setq ret (shapeup-skeleton (cons points (cons lines aux-info)))) | ||
| 104 : | (clear-win win) | ||
| 105 : | (if grid (grid-win win)) | ||
| 106 : | (draw-skeleton-win win ret) | ||
| 107 : | (redraw-win win) | ||
| 108 : | ret)) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |