View of /lisp/tools/skeledit.l.10.15View of /lisp/tools/skeledit.l.10.15
Parent Directory
| 
Revision Log
*** empty log message ***
;; ----------------------------------------- ;;
;; skeledit.l kanji-skelton-editor ver 0.2 ;;
;; ;;
;; You need load `ulx' (UtiLisp X interface) ;;
;; ;;
;; You need (reload-skelton) ;;
;; ----------------------------------------- ;;
(comment
$Revision: 1.2 $
)
;; ----------------- ;;
;; for compiler bug? ;;
;; ----------------- ;;
(defun ulx-magic ()
)
;; ----------------------------- ;;
;; get window properties (macro) ;;
;; ----------------------------- ;;
(defmacro width-win (win)
`(get-winprop ,win 'width))
(defmacro height-win (win)
`(get-winprop ,win 'height))
;; --------------- ;;
;; make menu macro ;;
;; --------------- ;;
(defmacro create-menu (parent x y black white fnt cursor . item-list)
(let ((mw (gensym))
(height (gensym))
(width (gensym)))
(append
`(let ((,mw (create-win ,parent ,x ,y 10 10
,black ,white ,fnt))
(,height *menu-margin*)
(,width 0)))
(mapcar item-list
(function
(lambda (x)
`(progn
(setq ,(first x)
(create-menu-item-win
,mw
,(second x)
*menu-margin*
,height
,black
,white
,fnt
,cursor))
(setq ,height
(+ ,height (height-win ,(first x))))
(setq ,width
(max ,width (width-win ,(first x))))
(princ (quote ,(first x)))
(princ " ")))))
`((resize-win ,mw
(+ ,width (* 4 *menu-margin*))
(+ ,height (* 2 *menu-margin*))))
(mapcar item-list
(function (lambda (x)
`(resize-win ,(first x) ,width))))
`(,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 (applykanji name))
(initialize-editor-screen)
(activate-menu edit-kanji-primitive-menu)
(handle-button-press move-point 1 0 0))
(defun initialize-kana-edittee (name)
(setq edittee-name name)
(setq niti (applykanji name))
(initialize-editor-screen)
(activate-menu edit-kana-primitive-menu)
(handle-button-press add-hira-long 1 0 0))
(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 ()
(print 'anonymous)
(setq niti nil)
(initialize-editor-screen)
(activate-menu nil))
(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))
(call (string-append "chmod og+w " output-file-name))
(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 (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 skelton-edit ((nit 'unknown-primitive) (opname "/tmp/prim.out"))
(setq output-file-name opname)
(when (<> (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)
(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))
(t
(initialize-anonymous-edittee)))
(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 kanji-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 kanji-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 kana-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 kana-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)))))
(comment put-winprop
nikuduke-joint-prim 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(draw-nikuduked-skelton-win! editor
joint-prim-def
'mincho)))
(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-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 kanji-prim-ed 'button-press-handler
#'(lambda (win code x y)
(activate-menu edit-kanji-primitive-menu)
(let ((sym
(do ((s (read-string-from-kinput skeleditor)
(read-string-from-kinput skeleditor)))
((kanji-primitive-name-? s) (intern s))
(beep editor))))
(save-edittee-to-file output-file-name message)
(initialize-kanji-edittee sym))))
(put-winprop kana-prim-ed 'button-press-handler
#'(lambda (win code x y)
(activate-menu edit-kana-primitive-menu)
(let ((sym
(do ((s (read-string-from-kinput skeleditor)
(read-string-from-kinput skeleditor)))
((kana-primitive-name-? s) (intern s))
(beep editor))))
(save-edittee-to-file output-file-name message)
(initialize-kana-edittee sym))))
(put-winprop kumiawase-ed 'button-press-handler
#'(lambda (win code x y)
(activate-menu edit-jointed-primitive-menu)
(let ((sym
(do ((s (read-string-from-kinput skeleditor)
(read-string-from-kinput skeleditor)))
((jointed-primitive-name-? s) (intern s))
(beep editor))))
(save-edittee-to-file output-file-name message)
(initialize-jointed-edittee sym))))
nil)
(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-string)
(let ((sym (intern sym-string)))
(and (boundp sym)
(eq sym (expandkanji sym))
(not (and (= (string-length sym-string) 2)
(or (= (sref sym-string 0) 164)
(= (sref sym-string 0) 165)))))))
(defun kana-primitive-name-? (sym-string)
(if (symbolp sym-string)
(setq sym-string (string sym-string)))
(let ((sym (intern sym-string)))
(and (boundp sym)
(eq sym (expandkanji sym))
(and (= (string-length sym-string) 2)
(or (= (sref sym-string 0) 164)
(= (sref sym-string 0) 165))))))
(defun jointed-primitive-name-? (sym-string)
(let ((sym (intern sym-string))
(ex nil))
(and (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
(kanji-prim-ed "漢字プリ編集")
(kana-prim-ed "かなプリ編集")
(kumiawase-ed "組合せ編集")
(nikuduke-min "肉付（明朝）")
(nikuduke-got "肉付（ゴシック）")
(etc-1 "テスト用１")
(etc-2 "テスト用２")
(syuuryou "終わり")))
(incr y (+ (height-win edit-common-menu) *menu-margin*))
(setq edit-kanji-primitive-menu
(create-menu skeleditor 0 y black white kanji-font roupe-cursor
(move-point "点の移動")
(toggle-link "点の接続／非接続")
(delete-element "線の削除")
(kanji-part-move "一部を平行移動")
(kanji-part-resize "一部を拡大縮小")))
(let ((yy (+ y (height-win edit-kanji-primitive-menu) *menu-margin*)))
(setq edit-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 "こざとの右")))
(setq edit-kanji-primitive-menu-sub-2
(create-menu skeleditor (width-win edit-kanji-primitive-menu-sub-1)
yy black white kanji-font roupe-cursor
(add-tatehane "たてはね")
(add-tsukurihane "つくりはね")
(add-sanzui "さんずい下")
(add-kokoro "心の一部")
(add-tasuki "たすき")
(add-magaritate "曲がり縦棒")
(add-kagi "かぎ")
(add-shinnyuu "しんにゅう")))
(put-winprop edit-kanji-primitive-menu 'next-menu
(list edit-kanji-primitive-menu-sub-1
edit-kanji-primitive-menu-sub-2)))
(setq edit-kana-primitive-menu
(create-menu skeleditor 0 y black white kanji-font roupe-cursor
(add-hira-long "・長い仮名")
(add-hira-short "・短い仮名")
(add-hira-maru "・ぱぴぷぺぽの丸")
(hira-width "平仮名の太さ")
(hira-lengthen "平仮名を長くする")
(hira-long-pnt-add "平仮名の点を追加")
(hira-shorten "平仮名の点を削除")
(kana-part-move "一部を平行移動")
(kana-part-resize "一部を拡大縮小")))
(setq edit-jointed-primitive-menu
(create-menu skeleditor 0 y black white kanji-font roupe-cursor
(move-joint-prim "組合せ内の移動")
(resize-joint-prim "組合せ内の拡縮")))
(incr y (+ (max (+ (height-win edit-kanji-primitive-menu)
(max (height-win edit-kanji-primitive-menu-sub-1)
(height-win edit-kanji-primitive-menu-sub-2)))
(height-win edit-kana-primitive-menu)
(height-win edit-jointed-primitive-menu))
*menu-margin*))
(setq edit-menus (list edit-common-menu
edit-kanji-primitive-menu
edit-kana-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-kanji-primitive-menu-sub-1)
(width-win edit-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-primitive-menu)
(unmap-menu edit-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 |