View of /lisp/tools/skeledit.l.10.12View of /lisp/tools/skeledit.l.10.12
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)
(map-subwindows base)
(map-subwindows base2)
(map-subwindows width-sliders)
(map-subwindows skeleditor)
(map-window skeleditor))
(defun joint-primitive-? (prim)
(and (listp prim) (eq (car prim) 'joint)))
(defun initialize-edittee (name)
(setf (window-cursor editor) please-wait-cursor)
(put-winprop editor 'motion-notify-handler #'(lambda (win x y)))
(display-force-output display)
(cond ((and (symbolp name) (not (null name)))
(setq joint-prim-symbol name)
(setq joint-prim-def (recursive-copy (expandkanji joint-prim-symbol)))
(setq niti joint-prim-def)
(unless (joint-primitive-? niti)
(setq edittee-name name)
(if (boundp 'edittee-name)
(push edittee-name edittee-history))
(setq niti (make-link-ok-from-old-version
(zahyou-flonum->fixnum (applykanji name))))
(if (not (pure-primitive-name? name))
(setq edittee-sub-primitives
(get-affine-of-kumiawased-primitive (eval name)))
(setq edittee-sub-primitives nil))))
(t
(setq edittee-name 'unknown-primitive)
(setq niti name)
(setq joint-prim-def name)
(setq edittee-sub-primitives nil)))
(print (list 'niti niti))
(print (list 'joint-prim-def joint-prim-def))
(setf (window-cursor editor) hair-cross-cursor)
(handle-button-press move-point 1 0 0)
(comment (prind niti)
(prind joint-prim-def))
(clear-win editor)
(draw-skelton-win editor
(if (and (listp joint-prim-def)
(eq (car joint-prim-def) 'joint))
joint-prim-def
niti))
(redraw-win editor)
(display-force-output display))
(defun save-edittee-to-file (output-file-name message)
(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)))
(defun skelton-edit ((niti '(nil nil)) (opname "/tmp/prim.out"))
(initialize-skelton-edit-sub)
(clear-win message)
(setq edittee-history nil)
(initialize-edittee niti)
(setq output-file-name opname)
(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)
(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)
(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 nop-nop-nop 'enter-notify-handler nil)
(put-winprop nop-nop-nop 'leave-notify-handler nil)
(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 kumiawase 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(let ((name (read-string-from-kinput skeleditor)))
(if (> (string-length name) 2)
(setq name (substring name 0 2)))
(setq name (intern name))
(print name)
(cond ((boundp name)
(setf (window-cursor editor) please-wait-cursor)
(setf (window-cursor win) please-wait-cursor)
(display-force-output (window-display editor))
(draw-nikuduked-skelton editor
(applykanji name)
'mincho)
(setf (window-cursor editor) hair-cross-cursor)
(setf (window-cursor win) roupe-cursor))
(t
(beep editor))))))
(put-winprop next-edittee 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(save-edittee-to-file output-file-name message)
(let ((name (read-string-from-kinput skeleditor)))
(loop
(if (boundp (intern name))
(exit))
(setq name (read-string-from-kinput skeleditor)))
(initialize-edittee (intern name)))))
(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)
))
(put-winprop sub-prim-edit 'button-press-handler
#'(lambda (win code x y)
(when edittee-sub-primitives
(select-window win code x y)
(setq %sub-primitive-name% nil)
(put-winprop editor 'motion-notify-handler
#'(lambda (win x y)
(nearest-sub-primitive-boxed win x y)))
(put-winprop
editor 'button-press-handler
#'(lambda (win code x y)
(let ((next (sub-primitive-info-current-xy x y)))
(save-edittee-to-file output-file-name
message)
(initialize-edittee (car next)))))
(setf (window-event-mask editor)
'(:exposure
:button-press
:pointer-motion)))))
(put-winprop motohe-modoru 'button-press-handler
#'(lambda (win code x y)
(print edittee-history)
(cond ((>= (length edittee-history) 2)
(select-window win code x y)
(save-edittee-to-file output-file-name message)
(pop edittee-history)
(comment print edittee-history)
(let ((next (pop edittee-history)))
(comment print (list 'next next))
(initialize-edittee next))))))
(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
set-joint-prim-name 'button-press-handler
#'(lambda (win code x y)
(select-window win code x y)
(save-edittee-to-file output-file-name message)
(setq joint-prim-name
(do ((newname (read-string-from-kinput skeleditor)
(read-string-from-kinput skeleditor))
(shortname "")
(ret nil))
((progn
(if (<= 2 (string-length newname))
(setq shortname (substring newname 0 2))
(setq shortname ""))
(cond ((boundp (intern newname))
(setq ret newname))
((boundp (intern shortname))
(setq ret shortname)))
ret)
ret)
(beep win)))
(initialize-edittee (intern joint-prim-name))
(comment progn
(print-message-win
message
(zenkaku-string (string-append "組合せの名前を「" joint-prim-name
"」に設定しました")))
(setq joint-prim-symbol (intern joint-prim-name))
(setq edittee-name joint-prim-symbol)
(cond ((eq (car (eval joint-prim-symbol)) 'joint)
(setq joint-prim-def (eval joint-prim-symbol)))
(t
(setq joint-prim-def (expandkanji joint-prim-symbol))))
(prind joint-prim-def)
(setq niti joint-prim-def))
(clear-win editor)
(draw-jointed-primitive-win editor joint-prim-def)
(redisplay-win editor)))
(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
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)
nil)
(defun make-skeledit-windows ()
(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)
(progn
(setq base (create-menu skeleditor 0 0 black white
kanji-font roupe-cursor
(move-point "点の移動")
(toggle-link "点の接続／非接続")
(delete-element "線の削除")
(nikuduke-min "肉付（明朝）")
(nikuduke-got "肉付（ゴシック）")
(add-ten "・点")
(add-tate "・縦棒")
(add-yoko "・横棒")
(add-migiue "・右上はね")
(add-hidari "・左はらい")
(add-tatehidari "・縦棒左はらい")
(add-migi "・右はらい")
(add-kozato "・こざとの一部")
(add-tatehane "・たてはね")
(add-tsukurihane "・つくりはね")
(add-sanzui "・さんずいの一部")
(add-kokoro "・心の一部")
(add-tasuki "・たすき")
(add-magaritate "・曲がり縦棒")
(add-kagi "・かぎ")
(add-shinnyuu "・しんにゅう")))
(setq base2 (create-menu skeleditor
(+ *menu-margin* (width-win base)) 0
black white kanji-font roupe-cursor
(hira-width "平仮名の太さ")
(add-hira-long "・長い平仮名")
(add-hira-short "・短い平仮名")
(add-hira-maru "・ぱぴぷぺぽの丸")
(hira-lengthen "平仮名を長くする")
(hira-long-pnt-add "平仮名の点を追加")
(hira-shorten "平仮名の点を削除")
(part-move "一部を平行移動")
(part-resize "一部を拡大縮小")
(kumiawase "？組合せ表示？")
(next-edittee "新しい漢字の編集")
(sub-prim-edit "プリミティブ編集")
(motohe-modoru "一つ前の漢字編集")
(nop-nop-nop "一一一一一一一一")
(set-joint-prim-name "組合せの名前設定")
(move-joint-prim "組合せ内の移動")
(resize-joint-prim "組合せ内の拡縮")
(nikuduke-joint-prim "組合せの肉付け")
(etc-1 "テスト用１")
(etc-2 "テスト用２")
(syuuryou "終わり")))
)
(setf (window-event-mask base) '(:exposure))
(setf (window-event-mask base2) '(:exposure))
(print 'base)
(setq editor (create-win skeleditor
(+ (width-win base) *menu-margin*
(width-win base2) *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 (height-win base)
(height-win base2)
(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))
600 50 black white kanji-font))
(print 'message)
(resize-win skeleditor
(max (+ (width-win base) (width-win base2)
(width-win editor) (* *menu-margin* 4))
(width-win message))
(max (+ (max (height-win base) (height-win base2)
(height-win editor))
(height-win width-sliders)
(height-win message)
(* *menu-margin* 4))
(height-win skeleditor)))
(connect-window-handlers))
(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 main-test ()
(initialize-skelton-editor)
(skelton-edit kanoji))
;;
;; (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 |