View of /lisp/tools/xyunit.l
Parent Directory
| Revision Log
Revision:
1.1 -
(
download)
(
annotate)
Thu Dec 28 08:54:20 2000 UTC (23 years, 7 months ago) by
ktanaka
Branch:
MAIN
Branch point for:
ktanaka
Initial revision
;; -------- ;;
;; xyunit.l ;;
;; -------- ;;
(defun get-prim-info (prim key)
(let* ((info (get-aux-info prim))
(loc (assq key info)))
loc))
(defun put-prim-info (prim key value)
(let ((loc (get-prim-info prim key)))
(if (null loc)
(nconc (get-aux-info prim) (ncons (cons key value)))
(setf (cdr loc) value))))
(defun center-of-primitive (prim)
(lets ((edges (range-of-primitive-of-jp prim #(1.0 0.0 0.0 1.0 0.0 0.0)))
(minimum (car edges))
(maximum (cadr edges)))
(list (quotient (plus (car minimum) (car maximum)) 2)
(quotient (plus (cadr minimum) (cadr maximum)) 2))))
(defun get-position:resize-boxes (win cx cy x y (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))
(comment print 'enter-resize-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)
(resize-boxes-win! win ,cx ,cy x y)))
(setf (window-event-mask win) '(:exposure
:button-press
:button-release
:pointer-motion))
(resize-boxes-win! win cx cy x y)
(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)
(comment print 'exit-resize-boxes-mode)
%pred-position%))
(defun draw-xor-center-box-win! (win cx cy x y)
(lets ((half-width (abs (difference cx x)))
(half-height (abs (difference cy y)))
(xx (if (lessp cx x) (difference cx half-width) x))
(yy (if (lessp cy y) (difference cy half-height) y)))
(draw-rectangle win
(get-winprop win 'xorgc)
xx yy (times 2 half-width) (times 2 half-height))))
(defun resize-boxes-win! (win cx cy x y)
(let ((now (list x y)))
(if %pred-position%
(when (not (equal %pred-position% (list x y)))
(lets ((px (car %pred-position%))
(py (cadr %pred-position%)))
(draw-xor-center-box-win! win cx cy px py))))
(draw-xor-center-box-win! win cx cy x y)
(setq %pred-position% now)))
(defun edit-xyunit-of-primitive (win x y niti)
(lets ((center (center-of-primitive niti))
(x0 (car center))
(y0 (cadr center))
(nxy (get-position:resize-boxes win x0 y0 x y *end-by-release*))
(nxunit
(times 2 (abs (difference x0 (car nxy)))))
(nyunit
(times 2 (abs (difference y0 (cadr nxy))))))
(put-prim-info niti 'xunit nxunit)
(put-prim-info niti 'yunit nyunit)
(clear-win editor)
(if grid (grid-win editor))
(draw-skelton-win editor niti)
(redisplay-win editor)
(setf (window-cursor editor) please-wait-cursor)
(display-force-output display)
(show-temporary-nikuduked-skeltons temporary-window)
(setf (window-cursor editor) hair-cross-cursor)
niti))
(defun draw-temporary-nikuduked-skelton-win! (win prim
xwid ywid
xofs yofs
(mincho-gothic 'mincho))
(setq prim (shapeup-skelton prim))
(when (not (null (car prim)))
(let ((outline (skelton2list (applykanji prim) mincho-gothic))
(save (get-winprop win 'button-press-handler))
(loopend nil))
(mapcar outline
#'(lambda (x)
(fill-polygon-win!
win
(mapcar (setpart1 x)
#'(lambda (xy)
(let ((r (cons (plus xofs
(quotient
(times xwid (car xy))
400))
(plus yofs
(quotient
(times ywid (cdr xy))
400)))))
r))))))
(display-force-output (window-display win)))))
(defun draw-temporary-nikuduked-skelton-win (win prim
xwid ywid
xofs yofs
(mincho-gothic 'mincho))
(setq prim (shapeup-skelton prim))
(when (not (null (car prim)))
(let ((outline (skelton2list (applykanji prim) mincho-gothic))
(save (get-winprop win 'button-press-handler))
(loopend nil))
(mapcar outline
#'(lambda (x)
(fill-polygon-win
win
(mapcar (setpart1 x)
#'(lambda (xy)
(let ((r (cons (plus xofs
(quotient
(times xwid (car xy))
400))
(plus yofs
(quotient
(times ywid (cdr xy))
400)))))
r)))))))))
(defun fill-polygon-win (win points (mode 'black))
(draw-lines (get-winprop win 'save)
(selectq mode
(white (get-winprop win 'savewhitegc))
(black (get-winprop win 'saveblackgc))
(t (funcall err:argument-type mode)))
(cons2flat points)
:fill-p t))
(defun remove-assq (a-list key)
(cond ((null a-list)
nil)
((eq (caar a-list) key)
(remove-assq (cdr a-list) key))
(t
(cons (car a-list)
(remove-assq (cdr a-list) key)))))
(defun remove-prim-info (prim key)
(let ((points (get-points prim))
(lines (get-lines prim))
(info (get-aux-info prim)))
(cons points
(cons lines
(remove-assq info key)))))
(defun remove-prim-xyunit (prim)
(remove-prim-info (remove-prim-info prim 'xunit) 'yunit))
(defun add-default-xyunit (prim)
(add-unit (remove-prim-xyunit prim)))