View of /lisp/tools/edhira.l
Parent Directory
|
Revision Log
Revision:
1.1.1.1 -
(
download)
(
annotate)
(vendor branch)
Thu Dec 28 08:54:20 2000 UTC (23 years, 8 months ago) by
ktanaka
Branch:
ktanaka
CVS Tags:
tmp
Changes since
1.1: +0 -0 lines
change to CVS wadalab font project
;;
;; edhira.l
;; $Revision: 1.1.1.1 $
;;
;; -------------------------- ;;
;; some traditional functions ;;
;; -------------------------- ;;
(defun tofix (x)
(if (floatp x)
(fix x)
x))
(defun toflo (x)
(if (fixp x)
(float x)
x))
;;
;; xor circle
;;
(defun draw-xorcircle-win! (win x y r)
(let ((diameter (+ r r)))
(draw-arc win
(get-winprop win 'xorgc)
(- x r) (- y r) diameter diameter 0 360)))
(defun drag-circles-win! (win x0 y0 r)
(if %pred-r%
(when (neq %pred-r% r)
(draw-xorcircle-win! win x0 y0 %pred-r%)
(draw-xorcircle-win! win x0 y0 r))
(draw-xorcircle-win! win x0 y0 r))
(setq %pred-r% r))
(defun get-radius:drag-circles (win x0 y0 r0 (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))
(center (list x0 y0))
(%pred-r% nil)
(%end% nil))
(comment print 'enter-drag-circles-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-r%
(fix (sqrt (float (distance-points
(list x y) ',center)))))))
(put-winprop win
'motion-notify-handler
`(lambda (win x y)
(drag-circles-win! win ,x0 ,y0
(fix (sqrt (float
(distance-points
(list x y)
',center)))))))
(setf (window-event-mask win) '(:exposure
:button-press
:button-release
:pointer-motion))
(drag-circles-win! win x0 y0 r0)
(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-drag-circles-mode)
%pred-r%))
;;
;; width of hiragana
;;
(defun change-hira-width (win code x y prim)
(lets ((ret nil)
(points (get-points prim))
(lines (get-lines prim))
(aux-info (get-aux-info prim))
(now (list x y)))
(if points
(lets ((nth-nearest (nth-of-nearest-point now points))
(nearest (nth nth-nearest points)))
(cond ((< (distance-points nearest now) *near-range*)
(lets ((element
(first (mem #'(lambda (x l) (memq x (second l)))
nth-nearest
lines)))
(p-nth (position nth-nearest (second element)))
(hira-w (get-info element 'hirawidth)))
(cond ((memq (first element) *has-hirawidth*)
(unless hira-w
(put-info element
'hirawidth
(make-list (length (second element))
*default-hirawidth*))
(setq hira-w (get-info element 'hirawidth))
(if grid (grid-win win))
(draw-skelton-win win prim)
(redraw-win win))
(let ((r (nth p-nth hira-w))
(x0 (first nearest))
(y0 (second nearest)))
(draw-xorcircle-win! win x0 y0 r)
(setf (nth p-nth hira-w)
(get-radius:drag-circles
win x0 y0
(fix (sqrt (float
(distance-points
(list x0 y0)
(list x y)))))
*end-by-release*))))
(t (rem-info element 'hirawidth)
(beep win)))))
(t (beep win))))
(beep win))
(setq ret (cons points (cons lines aux-info)))
(clear-win win)
(if grid (grid-win win))
(draw-skelton-win win ret)
(redraw-win win)
ret))
(defun draw-xorbox-win! (win x0 y0 x y)
(lets ((width (abs (- x x0)))
(height (abs (- y y0)))
(xx (if (< x x0) x (- x0 width)))
(yy (if (< y y0) y (- y0 height))))
(draw-rectangle win
(get-winprop win 'xorgc)
xx yy (* 2 width) (* 2 height))))
(defun drag-boxes-win! (win x0 y0 x y)
(let ((now (list x y)))
(if %pred-position%
(when (not (equal %pred-position% (list x y)))
(draw-xorbox-win! win
x0 y0
(first %pred-position%) (second %pred-position%))
(draw-xorbox-win! win x0 y0 x y))
(draw-xorbox-win! win x0 y0 x y))
(setq %pred-position% now)))
(defun get-position:drag-boxes (win x0 y0 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))
(print 'enter-drag-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)
(drag-boxes-win! win ,x0 ,y0 x y)))
(setf (window-event-mask win) '(:exposure
:button-press
:button-release
:pointer-motion))
(drag-boxes-win! win x0 y0 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-drag-circles-mode)
%pred-position%))