;; ----------------------------------------- ;;
;; 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))
;;      ...
;;