View of /lisp/tools/movebox.l
Parent Directory
| Revision Log
Revision:
1.3 -
(
download)
(
annotate)
Fri Jun 27 00:48:52 2003 UTC (21 years, 1 month ago) by
ktanaka
Branch:
MAIN
CVS Tags:
HEAD
Changes since
1.2: +0 -0 lines
FILE REMOVED
*** empty log message ***
;;-----------;;
;; movebox.l ;;
;;-----------;;
(defun move-boxes-win! (win x y xwid ywid)
(let ((now (list x y)))
(if %pred-position%
(when (not (equal %pred-position% (list x y)))
(draw-xorbox-win! win
(first %pred-position%) (second %pred-position%)
(+ (first %pred-position%) xwid)
(+ (second %pred-position%) ywid))
(draw-xorbox-win! win x y (+ x xwid) (+ y ywid)))
(draw-xorbox-win! win x y (+ x xwid) (+ y ywid)))
(setq %pred-position% now)))
(defun get-position:move-boxes (win x y xwid ywid (end-by-release nil))
(let ((save-bp-handler (get-winprop win 'button-press-handler))
(save-br-handler (get-winprop win 'button-release-handler))
(save-mn-handler (get-winprop win 'motion-notify-handler))
(save-event-mask (window-event-mask win))
(%pred-position% nil)
(%end% nil))
(print 'enter-move-boxes-mode)
(put-winprop win
(if (not end-by-release)
'button-release-handler
'button-press-handler)
nil)
(put-winprop win
(if end-by-release
'button-release-handler
'button-press-handler)
#'(lambda (win code x y)
(setq %end% t)
(setq %pred-position% (list x y))))
(put-winprop win
'motion-notify-handler
`(lambda (win x y)
(move-boxes-win! win x y ,xwid ,ywid)))
(setf (window-event-mask win) '(:exposure
:button-press
:button-release
:pointer-motion))
(move-boxes-win! win x y xwid ywid)
(loop-disable-other-win win #'(lambda () %end%))
(setf (window-event-mask win) save-event-mask)
(put-winprop win
'button-press-handler
save-bp-handler)
(put-winprop win
'button-release-handler
save-br-handler)
(put-winprop win
'motion-notify-handler
save-mn-handler)
(print 'exit-move-boxes-mode)
%pred-position%))
(defun draw-corner-xorbox-win! (win x0 y0 x y)
(let* ((minx (min x0 x))
(miny (min y0 y))
(widx (- (max x0 x) minx))
(widy (- (max y0 y) miny)))
(draw-rectangle win
(get-winprop win 'xorgc)
minx miny widx widy)))
(defun drag-corner-boxes-win! (win x0 y0 x y)
(let ((now (list x y)))
(if %pred-position%
(when (not (equal %pred-position% (list x y)))
(draw-corner-xorbox-win! win
x0 y0
(first %pred-position%)
(second %pred-position%))
(draw-corner-xorbox-win! win x0 y0 x y))
(draw-corner-xorbox-win! win x0 y0 x y))
(setq %pred-position% now)))
(defun move-some-points (win code x0 y0 prim (end-by-release nil))
(let ((save-bp-handler (get-winprop win 'button-press-handler))
(save-br-handler (get-winprop win 'button-release-handler))
(save-mn-handler (get-winprop win 'motion-notify-handler))
(save-event-mask (window-event-mask win))
(%pred-position% nil)
(%end% nil)
(xwid nil) (ywid nil)
(minx nil) (miny nil) (maxx nil) (maxy nil))
(catch 'exit-move-some
(put-winprop win
(if (not end-by-release)
'button-release-handler
'button-press-handler)
nil)
(put-winprop win
(if end-by-release
'button-release-handler
'button-press-handler)
#'(lambda (win code x y)
(setq %end% (if (eq code *end-mode*)
'exit-move-some
t))
(setq %pred-position% (list x y))))
(put-winprop win
'motion-notify-handler
`(lambda (win x y)
(drag-corner-boxes-win! win ,x0 ,y0 x y)))
(setf (window-event-mask win) '(:exposure
:button-press
:button-release
:pointer-motion))
(loop-disable-other-win win #'(lambda () %end%))
(if (eq %end% 'exit-move-some) (throw 'exit-move-some nil))
;;
;; I've got coodinates of the square's points already...
;;
(setq xwid (abs (- x0 (first %pred-position%)))
ywid (abs (- y0 (second %pred-position%))))
(setq minx (min x0 (first %pred-position%))
miny (min y0 (second %pred-position%)))
(setq maxx (+ minx xwid) maxy (+ miny ywid))
(setq xwid (// xwid 2) ywid (// ywid 2)
x0 (// (+ minx maxx) 2)
y0 (// (+ miny maxy) 2))
(comment draw-xorline-win! win minx miny maxx maxy)
(draw-corner-xorbox-win! win minx miny maxx maxy)
(draw-corner-dashbox-win! win minx miny maxx maxy)
(setq %pred-position% nil)
(setq %end% nil)
(put-winprop win
'button-press-handler
#'(lambda (win code x y)
(setq %end% (if (eq code *end-mode*)
'exit-move-some
t))
(setq %pred-position% (list x y))))
(put-winprop win
'motion-notify-handler
`(lambda (win x y)
(move-boxes-win! win x y ,xwid ,ywid)))
(setf (window-event-mask win) '(:exposure
:button-press
:button-release
:pointer-motion))
(move-boxes-win! win x0 y0 xwid ywid)
(loop-disable-other-win win #'(lambda () %end%))
(if (eq %end% 'exit-move-some) (throw 'exit-move-some nil))
(setq prim
(move-some-points-of-primitive minx maxx miny maxy
(- (first %pred-position%) x0)
(- (second %pred-position%) y0)
prim)))
(clear-win win)
(if grid (grid-win win))
(draw-skeleton-win win prim)
(redraw-win win)
(setf (window-event-mask win) save-event-mask)
(put-winprop win
'button-press-handler
save-bp-handler)
(put-winprop win
'button-release-handler
save-br-handler)
(put-winprop win
'motion-notify-handler
save-mn-handler)
prim))
(defun move-some-points-of-primitive (xmin xmax ymin ymax offx offy prim)
(let ((ret nil)
(points (get-points prim))
(lines (get-lines prim))
(aux-info (get-aux-info prim))
(now nil))
(setq points
(mapcar points
`(lambda (e)
(let* ((x (first e))
(y (second e))
(info (cddr e)))
(if (and (< xmin x) (< x xmax) (< ymin y) (< y ymax))
(cons (+ x offx) (cons (+ y offy) info))
e)))))
(setq ret (cons points (cons lines aux-info)))
ret))