View of /lisp/tools/skeledit.l.10.31View of /lisp/tools/skeledit.l.10.31
Parent Directory
| 
Revision Log
change to CVS wadalab font project
;; ----------------------------------------- ;;
;; skeledit.l kanji-skelton-editor ver 0.2 ;;
;; ;;
;; You need load `ulx' (UtiLisp X interface) ;;
;; ;;
;; You need (reload-skelton) ;;
;; ----------------------------------------- ;;
(comment
$Revision: 1.1.1.1 $
)
;; ----------------- ;;
;; for compiler bug? ;;
;; ----------------- ;;
(defun ulx-magic ()
)
;; --------------------- ;;
;; get window properties ;;
;; --------------------- ;;
(defun width-win (win)
(get-winprop win 'width))
(defun height-win (win)
(get-winprop win 'height))
(defun move-win (win x y)
(setf (drawable-x win) x)
(setf (drawable-y win) y))
;; --------------- ;;
;; make menu macro ;;
;; --------------- ;;
(defun create-menu (parent x y black white fnt cursor
item-list (colnum 1))
(lets ((mw (create-win parent x y 10 10 black white fnt))
(wins (mapcar item-list
#'(lambda (x)
(create-menu-item-win mw (second x)
0 0
black white
fnt cursor))))
(item-num (length item-list))
(item-height (apply #'max
(mapcar wins #'drawable-height)))
(item-width (apply #'max
(mapcar wins #'drawable-width)))
(linnum (// (1- (+ item-num colnum)) colnum))
(mw-height (+ (* linnum item-height) *menu-margin*))
(mw-width (+ (* colnum (+ *menu-margin* item-width))
(* 2 *menu-margin*))))
(do ((item-wins wins)
(y 0 (+ y item-height)))
((endp item-wins))
(do ((x *menu-margin* (+ x (+ item-width *menu-margin*)))
(c 0 (1+ c)))
((or (>= c colnum) (endp item-wins)))
(move-win (car item-wins) x y)
(setq item-wins (cdr item-wins))))
(do ((items item-list (cdr items))
(windefs wins (cdr windefs)))
((or (endp items) (endp windefs)))
(princ (caar items)) (princ " ")
(set (caar items) (car windefs)))
(terpri)
(mapcar wins #'(lambda (x) (resize-win x item-width item-height)))
(resize-win mw mw-width mw-height)
mw))
;; ------------------------------------ ;;
;; window-handler of addition primitive ;;
;; ------------------------------------ ;;
(defmacro connect-element-win (window editor prim eleme)
`(put-winprop ,window 'button-press-handler
(function
(lambda (win code x y)
(select-window win code x y)
(put-winprop
,editor
'button-press-handler
(function
(lambda (win code x y)
(setq ,prim
(add-skelton-element win
code x y
,prim ',eleme)))))))))
;; ----------- ;;
;; initializer ;;
;; ----------- ;;
(defun initialize-skelton-edit-sub ()
(comment
(unless (boundp '*near-cos-see-angle*)
(setq *near-cos-see-angle* (cos (//$ (*$ 160.0 (arccos 0.0)) 90.0)))))
(unless (boundp '*near-range*)
(setq *near-range* 400))
(unless (boundp '*menu-margin*)
(setq *menu-margin* 2))
(unless (boundp '*end-mode*)
(setq *end-mode* 3))
(unless (boundp '*select-nearest*)
(setq *select-nearest* 2))
(when (or (eq *end-mode* *select-nearest*)
(<= *end-mode* 0)
(<= *select-nearest* 0)
(> *end-mode* 3)
(> *select-nearest* 3))
(princ "*end-mode* or *select-nearest* out of range... set default")
(terpri)
(setq *select-nearest* 2)
(setq *end-mode* 3))
(unless (boundp '*link-near-range*)
(setq *link-near-range* 16))
(unless (boundp '*default-hirawidth*)
(setq *default-hirawidth* 8))
(unless (boundp '*default-slider-length*)
(setq *default-slider-length* 200))
(if (or (not (boundp '*range-too-large*))
(> *near-range* *range-too-large*))
(setq *range-too-large* (* 10 *near-range*)))
(if (boundp 'editor)
(put-winprop editor 'button-press-handler nil))
;; init-status is move-point-selected
(if (and (boundp '*selected-window*) *selected-window*)
(normal-win *selected-window*))
(setq *selected-window* nil)
)
;; ---------------- ;;
;; window selection ;;
;; ---------------- ;;
(defun select-window (win code x y)
(cond ((neq win *selected-window*)
(if *selected-window* (normal-win *selected-window*))
(setq *selected-window* win)
(highlight-win *selected-window*)))
(display-force-output (window-display win))
(setf (window-event-mask editor) '(:exposure
:pointer-motion
:button-release
:button-press))
(put-winprop editor 'button-press-handler nil)
(put-winprop editor 'button-release-handler nil)
(put-winprop editor 'motion-notify-handler nil)
(redraw-win editor))
;; -------------- ;;
;; motion-handler ;;
;; -------------- ;;
(defun print-pointer-position (win x y)
(print (list win x y)))
;; -------------- ;;
;; window example ;;
;; -------------- ;;
(defun initialize-skelton-editor ()
(ulx-magic)
(setup-display)
(print 'setup-display)
(initialize-skelton-edit-sub)
(print 'initialize)
(make-skeledit-windows))
(defun initialize-kanji-edittee (name)
(setq edittee-name name)
(setq niti (shapeup-skelton (applykanji name) t))
(setq joint-prim-def nil)
(setq joint-prim-symbol nil)
(initialize-editor-screen)
(activate-menu edit-kana-kanji-primitive-menu)
(handle-button-press move-point 1 0 0))
(defun force-kana-kanji-edittee ()
(setq edittee-name joint-prim-symbol)
(setq niti (shapeup-skelton (applykanji joint-prim-def) t))
(setq joint-prim-def nil)
(setq joint-prim-symbol nil)
(initialize-editor-screen)
(activate-menu edit-kana-kanji-primitive-menu)
(handle-button-press move-point 1 0 0))
(defun initialize-kana-edittee (name)
(initialize-kanji-edittee name))
(defun initialize-jointed-edittee (name)
(setq edittee-name name)
(setq joint-prim-symbol name)
(setq joint-prim-def (recursive-copy (expandkanji joint-prim-symbol)))
(setq niti joint-prim-def)
(initialize-editor-screen)
(activate-menu edit-jointed-primitive-menu)
(handle-button-press move-joint-prim 1 0 0))
(defun initialize-anonymous-edittee ((init nil))
(print 'anonymous)
(setq edittee-name 'anonymous)
(setq niti (if init
(shapeup-skelton (applykanji init) t)
'(nil nil)))
(setq joint-prim-def nil)
(setq joint-prim-symbol nil)
(initialize-editor-screen)
(activate-menu edit-kana-kanji-primitive-menu)
(handle-button-press add-ten 1 0 0))
(defun initialize-editor-screen ()
(setf (window-cursor editor) please-wait-cursor)
(put-winprop editor 'motion-notify-handler #'(lambda (win x y)))
(setf (window-cursor editor) hair-cross-cursor)
(clear-win editor)
(if niti
(draw-skelton-win editor niti))
(redraw-win editor)
(display-force-output display))
(defun save-edittee-to-file (output-file-name message)
(when (not (null niti))
(call (string-append "touch " output-file-name ">& /dev/null"))
(call (string-append "chmod og+w " output-file-name ">& /dev/null"))
(let* ((standard-output
(appendopen (stream output-file-name))))
(prind (list 'comment edittee-name
(getenv "USER") (date-time)
(cond ((pure-primitive-name? edittee-name)
'pure-primitive)
((eq (car niti) 'joint)
'jointed-primitives)
(t 'composite-primitive))))
(if (not (symbolp edittee-name))
(setq edittee-name 'anonymous))
(if (neq (car niti) 'joint)
(prind (list (if (pure-primitive-name? edittee-name)
'setq
'comment)
edittee-name (list 'quote niti)))
(print-in-detail (list (if (pure-primitive-name? edittee-name)
'setq
'comment)
edittee-name (list 'quote niti)))
(terpri))
(terpri)
(close standard-output))
(print-message-win
message
(zenkaku-string
(string-append "「" (string edittee-name)
"」を" output-file-name "に出力しました")))
(redraw-win message)
(display-force-output display)))
(setq niti nil)
(defun auto-select-and-initialize (nit)
(cond ((kanji-primitive-name-? nit)
(initialize-kanji-edittee nit))
((kana-primitive-name-? nit)
(initialize-kana-edittee nit))
((jointed-primitive-name-? nit)
(initialize-jointed-edittee nit))
((list-primitive-? nit)
(initialize-anonymous-edittee nit))
(t
(initialize-anonymous-edittee))))
(defun skelton-edit ((nit 'unknown-primitive) (opname "/tmp/prim.out"))
(setq output-file-name opname)
(when (and (= (call (string-append "test -f " output-file-name)) 0)
(= (call (string-append "test ! -w " output-file-name)) 0))
(beep editor)
(princ (string-append "file " output-file-name " is not writable"))
(terpri)
(funcall err:open-close))
(initialize-skelton-edit-sub)
(clear-win message)
(auto-select-and-initialize nit)
(initialize-editor-screen)
(print 'initialize)
(main-loop display
#'(lambda () (eq *selected-window* syuuryou))
editor)
(setq niti (shapeup-skelton niti))
(display-force-output display)
niti)
(defun connect-window-handlers ()
(put-winprop move-point 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'button-press-handler
(function
(lambda (win code x y)
(setq niti
(move-skelton-point win code x y niti)))))))
(put-winprop toggle-link 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'button-press-handler
(function
(lambda (win code x y)
(setq niti
(toggle-skelton-link win
code x y niti)))))))
(put-winprop delete-element 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'motion-notify-handler
#'(lambda (win x y)
(nearest-line-dotted win x y niti)))
(put-winprop
editor
'button-press-handler
(function
(lambda (win code x y)
(setq niti
(delete-skelton-element win
code x y niti)))))
(setf (window-event-mask editor) '(:exposure
:button-press
:pointer-motion))))
(put-winprop nikuduke-min 'button-press-handler
#'(lambda (win code x y)
(when niti
(select-window win code x y)
(setf (window-cursor editor) please-wait-cursor)
(setf (window-cursor win) please-wait-cursor)
(display-force-output (window-display editor))
(setq niti (shapeup-skelton niti))
(draw-nikuduked-skelton editor niti 'mincho)
(setf (window-cursor editor) hair-cross-cursor)
(setf (window-cursor win) roupe-cursor)
(display-force-output (window-display editor)))))
(put-winprop nikuduke-got 'button-press-handler
#'(lambda (win code x y)
(when niti
(select-window win code x y)
(setf (window-cursor editor) please-wait-cursor)
(setf (window-cursor win) please-wait-cursor)
(display-force-output (window-display editor))
(setq niti (shapeup-skelton niti))
(draw-nikuduked-skelton editor niti 'gothic)
(setf (window-cursor editor) hair-cross-cursor)
(setf (window-cursor win) roupe-cursor)
(display-force-output (window-display editor)))))
(put-winprop hira-width 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'button-press-handler
#'(lambda (win code x y)
(setq niti
(change-hira-width win code x y niti))))))
(put-winprop hira-lengthen 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'motion-notify-handler
#'(lambda (win x y)
(nearest-line-dotted win x y niti)))
(put-winprop
editor
'button-press-handler
#'(lambda (win code x y)
(setq niti
(make-hira-element-long win code x y niti))))
(setf (window-event-mask editor) '(:exposure
:button-release
:button-press
:pointer-motion))))
(put-winprop part-move 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'button-press-handler
#'(lambda (win code x y)
(setq niti
(move-some-points win code x y niti))))))
(put-winprop part-resize 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop
editor
'button-press-handler
#'(lambda (win code x y)
(setq niti
(resize-some-points win code x y niti))))))
(put-winprop syuuryou 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(save-edittee-to-file output-file-name message)
(when current-selected-menu
(unmap-menu current-selected-menu))
(setq current-selected-menu nil)
))
(put-winprop hira-long-pnt-add 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(setup-add-hira-point)
(put-winprop editor 'button-press-handler
#'(lambda (win code x y)
(setq niti
(add-hira-point win x y niti))))))
(put-winprop
move-joint-prim 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop editor 'button-press-handler
#'(lambda (win code x y)
(setq joint-prim-def
(move-primitive-of-jointed-primitive
win code x y))
(setq niti joint-prim-def)))))
(put-winprop
resize-joint-prim 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(put-winprop editor 'button-press-handler
#'(lambda (win code x y)
(setq joint-prim-def
(resize-primitive-of-jointed-primitive
win code x y))
(setq niti joint-prim-def)))))
(put-winprop hira-shorten 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(setup-del-hira-point)
(put-winprop editor 'button-press-handler
#'(lambda (win code x y)
(setq niti
(del-hira-point editor x y niti))))))
(put-winprop etc-1 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(when (or (null (get-prim-info niti 'xunit))
(null (get-prim-info niti 'yunit)))
(setq niti (add-unit niti))
(clear-win editor)
(draw-skelton-win editor niti)
(redisplay-win editor))
(put-winprop
editor 'button-press-handler
#'(lambda (win code x y)
(setq niti (edit-xyunit-of-primitive win x y niti))))))
(put-winprop etc-2 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)))
(connect-element-win add-ten editor niti ten)
(connect-element-win add-tate editor niti tate)
(connect-element-win add-yoko editor niti yoko)
(connect-element-win add-migiue editor niti migiue)
(connect-element-win add-hidari editor niti hidari)
(connect-element-win add-tatehidari editor niti tatehidari)
(connect-element-win add-migi editor niti migi)
(connect-element-win add-kozato editor niti kozato)
(connect-element-win add-tatehane editor niti tatehane)
(connect-element-win add-tsukurihane editor niti tsukurihane)
(connect-element-win add-sanzui editor niti sanzui)
(connect-element-win add-kokoro editor niti kokoro)
(connect-element-win add-tasuki editor niti tasuki)
(connect-element-win add-magaritate editor niti magaritate)
(connect-element-win add-kagi editor niti kagi)
(connect-element-win add-shinnyuu editor niti shin-nyuu)
(connect-element-win add-hira-long editor niti hira-long)
(connect-element-win add-hira-short editor niti hira-short)
(connect-element-win add-hira-maru editor niti hira-circle)
(put-winprop editor 'button-press-handler nil)
(put-winprop force-primitive 'button-press-handler
#'(lambda (win code x y)
(cond ((null joint-prim-def)
(beep editor))
(t
(and (ask-y-n message
"プリミティブに変換します")
(force-kana-kanji-edittee))))))
(put-winprop change-name 'button-press-handler
#'(lambda (win code x y)
(let ((sym (intern (read-string-from-kinput skeleditor))))
(save-edittee-to-file output-file-name message)
(auto-select-and-initialize sym))))
nil)
(defun ask-y-n (msg-win msg)
(princ-message-win msg-win (zenkaku-string (string-append msg "か?(y/n)")))
(redisplay-win msg-win)
(lets ((ans (read-string-from-kinput skeleditor))
(ret (or (string-equal ans "y")
(string-equal ans "Y")
(string-equal ans "ｙ")
(string-equal ans "Ｙ"))))
(if ret
(print-message-win msg-win "はい")
(print-message-win msg-win "いいえ"))
ret))
(defun activate-menu (menu (at-first t))
(when (and current-selected-menu at-first)
(unmap-menu current-selected-menu))
(when menu
(map-subwindows menu)
(map-window menu)
(mapcar (get-winprop menu 'next-menu)
#'(lambda (m) (activate-menu m nil))))
(if at-first (setq current-selected-menu menu)))
(defun kanji-primitive-name-? (sym)
(and (symbolp sym)
(boundp sym)
(eq sym (expandkanji sym))
(let ((sym-string (string sym)))
(not (and (= (string-length sym-string) 2)
(or (= (sref sym-string 0) 164)
(= (sref sym-string 0) 165)))))))
(defun kana-primitive-name-? (sym)
(and (symbolp sym)
(boundp sym)
(eq sym (expandkanji sym))
(print sym)
(let ((sym-string (string sym)))
(and (= (string-length sym-string) 2)
(or (= (sref sym-string 0) 164)
(= (sref sym-string 0) 165))))))
(defun list-primitive-? (nit)
(and (not (symbolp nit))
(setq nit (applykanji nit))
(listp nit)
(listp (car nit))
(listp (caar nit))
(numberp (caaar nit))))
(defun jointed-primitive-name-? (sym)
(let ((ex nil))
(or (and (listp sym)
(symbolp (car sym)))
(and (symbolp sym)
(boundp sym)
(neq sym (setq ex (expandkanji sym)))
(listp ex)
(eq (car ex) 'joint)))))
(defun make-skeledit-windows ()
(let ((menu-width 0)
(menu-height 0)
(edit-menus nil)
(y 0))
(setq skeleditor (create-win root 0 0 10 10 black white kanji-font))
(setf (window-event-mask skeleditor) '(:exposure :property-change))
(setf (wm-name skeleditor) "skelton editor")
(print 'skeleditor)
(setq edit-common-menu
(create-menu skeleditor 0 0 black white kanji-font roupe-cursor
'((change-name "次の編集")
(nikuduke-min "肉付（明朝）")
(nikuduke-got "肉付（ゴシック）")
(etc-1 "テスト用１")
(etc-2 "テスト用２")
(syuuryou "終わり"))))
(incr y (+ (height-win edit-common-menu) *menu-margin*))
(setq edit-kana-kanji-primitive-menu
(create-menu skeleditor 0 y black white kanji-font roupe-cursor
'((move-point "点の移動")
(toggle-link "点の接続／非接続")
(delete-element "線の削除")
(part-move "一部を平行移動")
(part-resize "一部を拡大縮小"))))
(let ((yy (+ y (height-win edit-kana-kanji-primitive-menu) *menu-margin*)))
(setq edit-kana-kanji-primitive-menu-sub-1
(create-menu skeleditor 0 yy black white kanji-font roupe-cursor
'((add-ten "点")
(add-tate "縦棒")
(add-yoko "横棒")
(add-migiue "右上撥")
(add-hidari "左払")
(add-tatehidari "縦左払")
(add-migi "右払")
(add-kozato "阜一部")
(add-tatehane "縦撥")
(add-tsukurihane "旁撥")
(add-sanzui "三水下")
(add-kokoro "心一部"))))
(setq edit-kana-kanji-primitive-menu-sub-2
(create-menu skeleditor
(+ (width-win edit-kana-kanji-primitive-menu-sub-1)
*menu-margin*)
yy black white kanji-font roupe-cursor
'((add-tasuki "たすき")
(add-magaritate "曲り縦棒")
(add-kagi "かぎ")
(add-shinnyuu "之繞")
(add-hira-long "長い仮名")
(add-hira-short "短い仮名")
(add-hira-maru "仮名の丸")
(hira-width "仮名の太")
(hira-lengthen "仮名長く")
(hira-long-pnt-add "仮名追加")
(hira-shorten "仮名削除"))))
(put-winprop edit-kana-kanji-primitive-menu 'next-menu
(list edit-kana-kanji-primitive-menu-sub-1
edit-kana-kanji-primitive-menu-sub-2)))
(setq edit-jointed-primitive-menu
(create-menu skeleditor 0 y black white kanji-font roupe-cursor
'((move-joint-prim "組合せ内の移動")
(resize-joint-prim "組合せ内の拡縮")
(force-primitive "プリミティブ変換"))))
(incr y (+ (max (+ (height-win edit-kana-kanji-primitive-menu)
(max (height-win edit-kana-kanji-primitive-menu-sub-1)
(height-win edit-kana-kanji-primitive-menu-sub-2)))
(height-win edit-jointed-primitive-menu))
*menu-margin*))
(setq edit-menus (list edit-common-menu
edit-kana-kanji-primitive-menu
edit-jointed-primitive-menu))
(mapcar edit-menus
#'(lambda (menu)
(setf (window-event-mask menu) '(:exposure))))
(print 'menus)
(setq menu-width
(max (apply #'max
(mapcar edit-menus
#'(lambda (menu) (width-win menu))))
(+ (width-win edit-kana-kanji-primitive-menu-sub-1)
(width-win edit-kana-kanji-primitive-menu-sub-2))))
(setq menu-height y)
(setq editor (create-win skeleditor
(+ menu-width *menu-margin*)
0
400 400 black white kanji-font))
(setf (window-event-mask editor) '(:exposure :button-press))
(setf (window-cursor editor) hair-cross-cursor)
(print 'editor)
(setq width-sliders
(create-slider-menu skeleditor
0
(+ (max menu-height (height-win editor))
*menu-margin*)
black white kanji-font
(min-wid "明朝基準太さ "
5.0 30.0 'minchowidth 20.0)
(got-wid "ゴシック基準太さ"
5.0 30.0 'gothicwidth 13.0)
(hir-wid "平仮名基準太さ "
0.0 1.5 'hirawidth 0.6)))
(print 'sliders)
(setq message (create-win skeleditor
0
(+ (drawable-y width-sliders) *menu-margin*
(height-win width-sliders))
500 50 black white kanji-font))
(print 'message)
(resize-win skeleditor
(max (+ menu-width
(width-win editor) (* *menu-margin* 4))
(width-win message))
(max (+ (max menu-height (height-win editor))
(height-win width-sliders)
(height-win message)
(* *menu-margin* 4))
(height-win skeleditor)))
(connect-window-handlers)
(map-subwindows edit-common-menu)
(map-subwindows width-sliders)
(map-subwindows skeleditor)
(unmap-menu edit-kana-kanji-primitive-menu)
(unmap-menu edit-jointed-primitive-menu)
(setq current-selected-menu nil)
(map-window skeleditor)))
(defun unmap-menu (menu)
(mapcar (get-winprop menu 'next-menu)
#'(lambda (m)
(unmap-menu m)))
(unmap-subwindows menu)
(unmap-window menu))
(defun print-in-detail (p)
(cond ((stringp p) (prind p) (princ " "))
((vectorp p)
(princ "#(")
(do ((len (vector-length p))
(i 0 (1+ i)))
((>= i len))
(print-in-detail (vref p i))
(princ " "))
(princ ") "))
((listp p)
(princ "(")
(let ((last (do ((rest p (cdr rest)))
((endp rest) rest)
(print-in-detail (car rest)))))
(if (null last)
(princ ") ")
(princ " . ")
(princ last)
(princ " ) "))))
((atom p) (princ p) (princ " "))
(t (prind p)))
nil)
;;
;; (defun takobeya ()
;; (initialize-skelton-editor)
;; (setq boo (skelton-edit boo))
;; (setq foo (skelton-edit foo))
;; (setq woo (skelton-edit woo))
;; ...
;;
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |