Annotation of /skeleton-edit/resizebox.lAnnotation of /skeleton-edit/resizebox.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;;-------------;; |
| 2 : | ;; resizebox.l ;; | ||
| 3 : | ;;-------------;; | ||
| 4 : | |||
| 5 : | (defun draw-corner-dashbox-win! (win x0 y0 x1 y1) | ||
| 6 : | (let* ((minx (min x0 x1)) | ||
| 7 : | (miny (min y0 y1)) | ||
| 8 : | (widx (- (max x0 x1) minx)) | ||
| 9 : | (widy (- (max y0 y1) miny))) | ||
| 10 : | (draw-rectangle win | ||
| 11 : | (get-winprop win 'dashlinegc) | ||
| 12 : | minx miny | ||
| 13 : | widx widy))) | ||
| 14 : | |||
| 15 : | (defun resize-some-points (win code x0 y0 prim (end-by-release nil)) | ||
| 16 : | (let ((save-bp-handler (get-winprop win 'button-press-handler)) | ||
| 17 : | (save-br-handler (get-winprop win 'button-release-handler)) | ||
| 18 : | (save-mn-handler (get-winprop win 'motion-notify-handler)) | ||
| 19 : | (save-event-mask (window-event-mask win)) | ||
| 20 : | (%pred-position% nil) | ||
| 21 : | (%end% nil) | ||
| 22 : | (minx nil) (miny nil) (maxx nil) (maxy nil)) | ||
| 23 : | |||
| 24 : | (catch 'exit-resize-some | ||
| 25 : | (put-winprop win | ||
| 26 : | (if (not end-by-release) | ||
| 27 : | 'button-release-handler | ||
| 28 : | 'button-press-handler) | ||
| 29 : | nil) | ||
| 30 : | |||
| 31 : | (put-winprop win | ||
| 32 : | (if end-by-release | ||
| 33 : | 'button-release-handler | ||
| 34 : | 'button-press-handler) | ||
| 35 : | #'(lambda (win code x y) | ||
| 36 : | (setq %end% (if (eq code *end-mode*) | ||
| 37 : | 'exit-resize-some | ||
| 38 : | t)) | ||
| 39 : | (setq %pred-position% (list x y)))) | ||
| 40 : | |||
| 41 : | (put-winprop win | ||
| 42 : | 'motion-notify-handler | ||
| 43 : | `(lambda (win x y) | ||
| 44 : | (drag-corner-boxes-win! win ,x0 ,y0 x y))) | ||
| 45 : | |||
| 46 : | (setf (window-event-mask win) '(:exposure | ||
| 47 : | :button-press | ||
| 48 : | :button-release | ||
| 49 : | :pointer-motion)) | ||
| 50 : | |||
| 51 : | (loop-disable-other-win win #'(lambda () %end%)) | ||
| 52 : | |||
| 53 : | (if (eq %end% 'exit-resize-some) (throw 'exit-resize-some nil)) | ||
| 54 : | |||
| 55 : | ;; | ||
| 56 : | ;; I've got coodinates of the square's points already... | ||
| 57 : | ;; | ||
| 58 : | (setq minx x0 | ||
| 59 : | miny y0 | ||
| 60 : | maxx (first %pred-position%) | ||
| 61 : | maxy (second %pred-position%)) | ||
| 62 : | |||
| 63 : | (draw-corner-xorbox-win! win minx miny maxx maxy) | ||
| 64 : | (draw-corner-dashbox-win! win minx miny maxx maxy) | ||
| 65 : | |||
| 66 : | (setq %pred-position% nil) | ||
| 67 : | (setq %end% nil) | ||
| 68 : | |||
| 69 : | (put-winprop win | ||
| 70 : | 'button-press-handler | ||
| 71 : | #'(lambda (win code x y) | ||
| 72 : | (setq %end% (if (eq code *end-mode*) | ||
| 73 : | 'exit-resize-some | ||
| 74 : | t)) | ||
| 75 : | (setq %pred-position% (list x y)))) | ||
| 76 : | |||
| 77 : | (put-winprop win | ||
| 78 : | 'motion-notify-handler | ||
| 79 : | `(lambda (win x y) | ||
| 80 : | (drag-corner-boxes-win! win ,x0 ,y0 x y))) | ||
| 81 : | |||
| 82 : | (setf (window-event-mask win) '(:exposure | ||
| 83 : | :button-press | ||
| 84 : | :button-release | ||
| 85 : | :pointer-motion)) | ||
| 86 : | |||
| 87 : | (loop-disable-other-win win #'(lambda () %end%)) | ||
| 88 : | |||
| 89 : | (if (eq %end% 'exit-resize-some) (throw 'exit-resize-some nil)) | ||
| 90 : | |||
| 91 : | (setq prim | ||
| 92 : | (resize-some-points-of-primitive minx miny | ||
| 93 : | maxx maxy | ||
| 94 : | x0 y0 | ||
| 95 : | (first %pred-position%) | ||
| 96 : | (second %pred-position%) | ||
| 97 : | prim))) | ||
| 98 : | |||
| 99 : | (clear-win win) | ||
| 100 : | (if grid (grid-win win)) | ||
| 101 : | (draw-skeleton-win win prim) | ||
| 102 : | (redraw-win win) | ||
| 103 : | |||
| 104 : | (setf (window-event-mask win) save-event-mask) | ||
| 105 : | (put-winprop win | ||
| 106 : | 'button-press-handler | ||
| 107 : | save-bp-handler) | ||
| 108 : | (put-winprop win | ||
| 109 : | 'button-release-handler | ||
| 110 : | save-br-handler) | ||
| 111 : | (put-winprop win | ||
| 112 : | 'motion-notify-handler | ||
| 113 : | save-mn-handler) | ||
| 114 : | prim)) | ||
| 115 : | |||
| 116 : | (defun resize-some-points-of-primitive (x0 y0 x1 y1 | ||
| 117 : | newx newy newmaxx newmaxy prim) | ||
| 118 : | (let ((ret nil) | ||
| 119 : | (points (get-points prim)) | ||
| 120 : | (lines (get-lines prim)) | ||
| 121 : | (aux-info (get-aux-info prim)) | ||
| 122 : | (now nil)) | ||
| 123 : | |||
| 124 : | (setq points | ||
| 125 : | (mapcar points | ||
| 126 : | `(lambda (e) | ||
| 127 : | (let* ((x (first e)) | ||
| 128 : | (y (second e)) | ||
| 129 : | (info (cddr e))) | ||
| 130 : | (if (and (or (and (< x0 x) (< x x1)) | ||
| 131 : | (and (< x1 x) (< x x0))) | ||
| 132 : | (or (and (< y0 y) (< y y1)) | ||
| 133 : | (and (< y1 y) (< y y0)))) | ||
| 134 : | (let ((xm (- x x0)) | ||
| 135 : | (xn (- x1 x)) | ||
| 136 : | (ym (- y y0)) | ||
| 137 : | (yn (- y1 y))) | ||
| 138 : | (cons (divide-m-n newx newmaxx xm xn) | ||
| 139 : | (cons (divide-m-n newy newmaxy ym yn) | ||
| 140 : | info))) | ||
| 141 : | e))))) | ||
| 142 : | |||
| 143 : | (setq ret (cons points (cons lines aux-info))) | ||
| 144 : | ret)) | ||
| 145 : | |||
| 146 : | (defun divide-m-n (x1 x2 m n) | ||
| 147 : | (// (+ (* x1 n) (* x2 m)) (+ m n))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |