Annotation of /lisp/tools/hirapoint.lAnnotation of /lisp/tools/hirapoint.l
Parent Directory
| 
Revision Log
Revision: 1.3 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; ----------- ;; |
| 2 : | ;; hirapoint.l ;; | ||
| 3 : | ;; ----------- ;; | ||
| 4 : | |||
| 5 : | (defun nearest-two-point-of-hira (prim x y) | ||
| 6 : | (let ((points (get-points prim)) | ||
| 7 : | (lines (get-lines prim)) | ||
| 8 : | (info (get-aux-info prim)) | ||
| 9 : | (maxdist *near-range*) | ||
| 10 : | (ret nil)) | ||
| 11 : | (mapcar | ||
| 12 : | lines | ||
| 13 : | #'(lambda (l) | ||
| 14 : | ; tanaka 1993/9/20 | ||
| 15 : | (when (memq (car l) '(hira-long outline stroke)) | ||
| 16 : | (let* ((p-no (cadr l)) | ||
| 17 : | (p-1 (car p-no)) | ||
| 18 : | (p-2 nil)) | ||
| 19 : | (do ((p (cdr p-no) (cdr p))) | ||
| 20 : | ((null p)) | ||
| 21 : | (setq p-2 (car p)) | ||
| 22 : | (let* ((pp-1 (nth p-1 points)) | ||
| 23 : | (pp-2 (nth p-2 points)) | ||
| 24 : | (dist (distance-point-line (list x y) | ||
| 25 : | (list pp-1 pp-2)))) | ||
| 26 : | (when (< dist maxdist) | ||
| 27 : | (setq maxdist dist) | ||
| 28 : | (setq ret (list p-1 p-2 pp-1 pp-2)))) | ||
| 29 : | (setq p-1 p-2)))))) | ||
| 30 : | (cond ((null ret) | ||
| 31 : | nil) | ||
| 32 : | ((< maxdist *near-range*) | ||
| 33 : | ret) | ||
| 34 : | (t | ||
| 35 : | nil)))) | ||
| 36 : | |||
| 37 : | (defun draw-two-point-of-hira-win! (win point-of-hira) | ||
| 38 : | (let* ((pp-1 (third point-of-hira)) | ||
| 39 : | (pp-2 (fourth point-of-hira)) | ||
| 40 : | (x0 (car pp-1)) | ||
| 41 : | (y0 (cadr pp-1)) | ||
| 42 : | (x1 (car pp-2)) | ||
| 43 : | (y1 (cadr pp-2))) | ||
| 44 : | (draw-xorline-win! win x0 y0 x1 y1))) | ||
| 45 : | |||
| 46 : | (comment defun draw-xor-part-of-hira-win! (win prim x y) | ||
| 47 : | (let ((selected (nearest-two-point-of-hira prim x y))) | ||
| 48 : | (if %end% | ||
| 49 : | (unless (equal %end% selected) | ||
| 50 : | (draw-two-point-of-hira-win! %end%) | ||
| 51 : | (setq %end% selected) | ||
| 52 : | (draw-two-point-of-hira-win! selected)) | ||
| 53 : | (draw-two-point-of-hira-win! selected) | ||
| 54 : | (setq %end% selected)))) | ||
| 55 : | |||
| 56 : | (defun setup-add-hira-point () | ||
| 57 : | (setq %end% nil)) | ||
| 58 : | |||
| 59 : | (defun add-hira-point (win x y prim) | ||
| 60 : | (let* ((selected (nearest-two-point-of-hira prim x y))) | ||
| 61 : | (if (null selected) | ||
| 62 : | (progn (beep win) prim) | ||
| 63 : | (let* ((points (get-points prim)) | ||
| 64 : | (lines (get-lines prim)) | ||
| 65 : | (info (get-aux-info prim)) | ||
| 66 : | (newpnt (list x y)) | ||
| 67 : | (newnth (length points)) | ||
| 68 : | (begpnt (car selected)) | ||
| 69 : | (endpnt (cadr selected)) | ||
| 70 : | (hline nil) | ||
| 71 : | (hlnnth nil) | ||
| 72 : | (newlines nil) | ||
| 73 : | (i 0) | ||
| 74 : | (ret nil)) | ||
| 75 : | (mapcar lines | ||
| 76 : | #'(lambda (l) | ||
| 77 : | (let ((pnts (cadr l)) | ||
| 78 : | (info (cddr l))) | ||
| 79 : | (when (and (memq (car l) '(hira-long outline stroke)) | ||
| 80 : | (memq begpnt pnts) | ||
| 81 : | (memq endpnt pnts)) | ||
| 82 : | (let* ((top (takewhile `(lambda (x) (<> x ,begpnt)) | ||
| 83 : | pnts)) | ||
| 84 : | (btm | ||
| 85 : | (do ((l pnts (cdr l))(ret)) | ||
| 86 : | ((atom l)ret) | ||
| 87 : | (and (eq (car l) endpnt)(setq ret l)))) | ||
| 88 : | (wid (get-info l 'hirawidth)) | ||
| 89 : | (widtop nil) (widbtm nil) | ||
| 90 : | (newl nil)) | ||
| 91 : | (setq newl (cons (car l) | ||
| 92 : | (ncons (append top | ||
| 93 : | (ncons begpnt) | ||
| 94 : | (ncons newnth) | ||
| 95 : | btm)))) | ||
| 96 : | (when wid | ||
| 97 : | (put-info newl 'hirawidth | ||
| 98 : | (let ((tt | ||
| 99 : | (topoflist wid (1+ (length top)))) | ||
| 100 : | (bb | ||
| 101 : | (nthcdr (1+ (length top)) wid))) | ||
| 102 : | (append tt | ||
| 103 : | (ncons (// (+ (car (last tt)) | ||
| 104 : | (car bb)) 2)) | ||
| 105 : | bb)))) | ||
| 106 : | (setq l newl))) | ||
| 107 : | (setq newlines (append newlines (ncons l)))))) | ||
| 108 : | (setq ret (cons (append points (ncons newpnt)) | ||
| 109 : | (cons newlines info))) | ||
| 110 : | (clear-win win) | ||
| 111 : | (if grid (grid-win win)) | ||
| 112 : | ktanaka | 1.2 | (draw-skeleton-win win ret) |
| 113 : | ktanaka | 1.1 | (redraw-win win) |
| 114 : | ret)))) | ||
| 115 : | |||
| 116 : | (defun topoflist (l n) | ||
| 117 : | (if (= n 0) | ||
| 118 : | nil | ||
| 119 : | (cons (car l) (topoflist (cdr l) (1- n))))) | ||
| 120 : | |||
| 121 : | (defun takewhile (pred? l) | ||
| 122 : | (if (or (null l) (not (funcall pred? (car l)))) | ||
| 123 : | nil | ||
| 124 : | (cons (car l) (takewhile pred? (cdr l))))) | ||
| 125 : | |||
| 126 : | (defun dropwhile (pred? l) | ||
| 127 : | (cond ((null l) nil) | ||
| 128 : | ((funcall pred? (car l)) (dropwhile pred? (cdr l))) | ||
| 129 : | (t l))) | ||
| 130 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |