View of /skeleton-edit/movebox.l

Parent Directory

Revision Log

*** 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))