View of /lisp/demo/kanjidemo.l

Parent Directory

Revision Log

change to CVS wadalab font project

;; 漢字文字列をベクタに変換
(defun kanji2vec (str)
  (lets ((len (// (string-length str) 2))
	 (vec (vector len)))
	(do ((i 0 (1+ i)))
	    ((>= i len)vec)
	    (vset vec i (+ (* 256 (logand 127 (sref str (* 2 i))))
			   (logand 127 (sref str (1+ (* 2 i)))))))))

;; ulx のロード
(defun init_window () 'dummy)
(cond ((definedp 'get-display-host) nil)
      (t (exfile (string-append system_lib_path "ulx/loadulx.l"))
	 (exfile "pack.l")
	 (exfile "all.l")
	 (exfile "disp.l")
	 (exfile "mincho.l")
	 (exfile "gothic.l")
	 (exfile "lib.l")
	 (exfile "joint.l")))

;; ディスプレイホストの設定
(setq display-host (get-display-host))
(or display-host (progn (format "Display unknown/n") (err:argument-type)))

;; スクリーンの定義
(setq display (open-display display-host))
(setq screen (first (display-roots display)))
(setq root (screen-root screen))
(setq window-of-menus root)

;; 白黒の定義
(setq black (screen-black-pixel screen)
      white (screen-white-pixel screen))

;; リクエストの直後に描画する
;; (setf (display-after-function display) 'display-force-output)

;; ウィンドウを作ってみる
(setq -all-smallwindows- nil)

(defstruct (smallwindow)
  window
  save
  gc
  revgc
  height
  width)

(defun create-smallwindow ((pare root) (title "unknown") (wid 400) (hei 400) (fontname "k14"))
  (lets ((nowfont (open-font display fontname))
	 (a (make-smallwindow
	     :window (create-window
		      :parent pare
		      :class  :input-output
		      :x 0
		      :y 0
		      :width wid
		      :height hei
		      :foreground black
		      :background white)
	     :save   (create-pixmap
		      :width wid   
		      :height hei
		      :drawable root
		      :depth 1)
	     :gc     (create-gcontext 
		      :drawable root
		      :foreground black 
		      :background white
		      :font nowfont)
	     :revgc (create-gcontext 
		     :drawable root
		     :foreground white
		     :background black
		     :font nowfont)
	     :width wid
	     :height hei)))
	(setf (wm-name (smallwindow-window a)) title)
	(setf (window-event-mask (smallwindow-window a)) 
	      '(:button-press :button-release :key-press :exposure))
	(map-window (smallwindow-window a))
	(draw-rectangle (smallwindow-save a) (smallwindow-revgc a) 0 0 wid hei t)
	(push a -all-smallwindows-)
	a))

;; ウィンドウを消す
(defun smallwindow-destroy (sw)
  (destroy-window (smallwindow-window sw)))

;; 真っ白にする
(defun smallwindow-clear (sw)
  (draw-rectangle (smallwindow-save sw) (smallwindow-revgc sw) 0 0 
		  (smallwindow-width sw) (smallwindow-height sw) t))

;; 描画を(再)表示する
(defun smallwindow-redraw (sw)
  (copy-area (smallwindow-save sw) (smallwindow-gc sw) 0 0 
	     (smallwindow-width sw) (smallwindow-height sw)
	     (smallwindow-window sw)
	     0 0))

;; 文字列を出力する
(defun smallwindow-putstr (sw x y str)
  (draw-glyphs (smallwindow-save sw) (smallwindow-gc sw) x y (kanji2vec str) :size 16))

;; 線を描く
(defun smallwindow-drawline (sw x1 y1 x2 y2)
  (draw-line (smallwindow-save sw) (smallwindow-gc sw) x1 y1 x2 y2))

(defun smallwindow-drawlines (sw points)
  (draw-lines (smallwindow-save sw) (smallwindow-gc sw)
	      (cons2flat points)
	      :complex t))

(defun smallwindow-fillpolygon (sw points)
  (draw-lines (smallwindow-save sw) (smallwindow-gc sw)
	      (cons2flat points)
	      :fill-p t
	      :complex t))

;; イベントのチェック
(defun buttonnmb (n)
  (nth (1- n) '(button1 button2 button3)))

(setq keytrans '(84 111 109 86 63 87 88 89 68 90 91 92 
		    113 112 69 70 61 64 85 65 67 110 62 108 66 107 83))

(defun search-smallwindow (event-window)
  (do ((rest -all-smallwindows- (cdr rest))
       (ret nil))
      (ret ret)
      (if (eq (smallwindow-window (car rest)) event-window)
	  (setq ret (car rest)))
      (if (null (cdr rest))
	  (print "???? display:error"))))

(defun all-smallwindow-checkevent ()
  (do ((ret nil)
       (key nil))
      (ret ret)
      (event-case (display)
		  (:exposure
		   (event-window count)
		   (let ((kouho (search-smallwindow event-window)))
		     ;;(princ "exposure ")
		     ;;(prind kouho)
		     (if (0= count) (smallwindow-redraw kouho)))
		   t)
		  (:button-press
		   (event-window code x y)
		   (setq ret `(ButtonPress ,(buttonnmb code) ,x ,y 
					   ,(search-smallwindow event-window)))
		   t)
		  (:button-release
		   (event-window code x y)
		   (setq ret `(ButtonRelease ,(buttonnmb code) ,x ,y 
					     ,(search-smallwindow event-window)))
		   t)
		  (:key-press
		   (event-window code x y)
		   (setq key (memq code keytrans))
		   (cond (key (setq code (- 124 (length key)))))
		   (setq ret `(KeyPress ,code ,(search-smallwindow event-window)))
		   t)
		  (otherwise
		   ()
		   t))))


(defun smallwindow-checkevent (sw)
  (do ((ret nil))
      (ret ret)
      (let ((events (all-smallwindow-checkevent)))
	;;(prind events)
	;;(prind (last events))
	;;(prind sw)
	(if (eq (car (last events)) sw)
	    (setq ret (reverse (cdr (reverse events))))))))

;; 歴史的な理由による関数群
(defun init_window (wid hei)
  (setq -traditional-window- (create-smallwindow root "utilisp" wid 400)))
(defun drawline (x0 y0 x1 y1)
  (smallwindow-drawline -traditional-window- x0 y0 x1 y1))
(defun redraw ()
  (smallwindow-redraw -traditional-window-))
(defun checkevent ()
  (smallwindow-checkevent -traditional-window-))
(defun close_window ()
  (smallwindow-destroy -traditional-window-))
(defun cons2flat (points)
  (do ((l points (cdr l))
       (ret nil))
      ((atom l)(nreverse ret))
      (push (caar l) ret)
      (push (cdar l) ret)))
(defun fillpolygon (points)
  (smallwindow-fillpolygon -traditional-window- points))
(defun drawlines (points)
  (smallwindow-drawlines -traditional-window- points))
(defun loadpbm (code))
(defun loadjis (code))
(defun copybg ()
  (smallwindow-clear -traditional-window-))

;; 漢字を表から選ぶ
;; (select-kanji) で漢字の文字列がえられる
(setq kanji-itiran-high -1)
(setq min-kanji-high 48
      max-kanji-high 79)

(defun display-kanji (start)
  (let ((high start))
    (if (< high min-kanji-high)  (setq high min-kanji-high))
    (if (> high max-kanji-high) (setq high max-kanji-high))
    (cond ((neq kanji-itiran-high high)
	   (setq kanji-itiran-high high)
	   (smallwindow-clear kanji-itiran)
	   (setq high (string (+ 128 high)))
	   (do ((low (+ 128 33))
		(disp-y 14 (+ 14 disp-y))
		(str "" ""))
	       ((> low 254))
	       (do ((count 0 (1+ count)))
		   ((>= count 16))
		   (cond ((<= low (+ 128 33)) 
			  (setq count 1)
			  (if (<= kanji-itiran-high min-kanji-high)
			      (setq str "＿")
			    (setq str "＜"))
			  (setq str (string-append str high (string low))))
			 ((> low 254)
			  (setq count 16)
			  (if (>= kanji-itiran-high max-kanji-high)
			      (setq str (string-append str "＿"))
			    (setq str (string-append str "＞"))))
			 (t (setq str (string-append str high (string low)))))
		   (setq low (1+ low)))
	       (smallwindow-putstr kanji-itiran 0 disp-y str)))))
  (smallwindow-redraw kanji-itiran))

(defun select-kanji ()
  (setq now-selected (-select-kanji-))
  (prind now-selected))

(defun -select-kanji- ()
  (display-kanji kanji-itiran-high)
  (do ((check (smallwindow-checkevent kanji-itiran) 
	      (smallwindow-checkevent kanji-itiran))
       (low-nth 0 0)
       (ret nil))
      (ret ret)
      (cond ((eq 'ButtonPress (first check))
	     (setq low-nth (+ (// (third check) 14)
			      (* (// (fourth check) 14) 16)))
	     (princ " ") (princ low-nth)
	     (cond ((and (< low-nth 95) (> low-nth 0))
		    (setq ret (string-append (string (+ kanji-itiran-high 128))
					     (string (+ low-nth 128 33 -1)))))
		   (t
		    (cond ((and (eq low-nth 0) (> kanji-itiran-high min-kanji-high))
			   (princ "pred-page ")
			   (display-kanji (1- kanji-itiran-high)))
			  ((and (eq low-nth 95) (< kanji-itiran-high max-kanji-high))
			   (princ "next-page ")
			   (display-kanji (1+ kanji-itiran-high))))))))))
 
;; メニューを作る
;; 呼び出し方法 (setq lang-menu (create-menu "Language" 
;;                          '(("ＡＰＬ" APL) ("Ｌｉｓｐ" Lisp))))
;;              (select-menu lang-menu)
;; 結果          =>   ("ＡＰＬ" APL) か ("Ｌｉｓｐ" Lisp)

(defstruct (menu)
  window
  items
)

(defun create-menu (title item-list (width 200))
  (let ((sw (make-menu
	     :window (create-smallwindow window-of-menus
					 title 
					 width
					 (+ (* 16 (length item-list)) 4))
	     :items  item-list)))
    (do ((names item-list (cdr names))
	 (disp-y 16 (+ 16 disp-y)))
	((null names) nil)
	;; (prind names)
	;; (prind disp-y)
	(smallwindow-putstr (menu-window sw) 0 disp-y (car (car names))))
    (smallwindow-redraw (menu-window sw))
    sw))

(defun select-menu (men)
  (do ((event (smallwindow-checkevent (menu-window men))
	      (smallwindow-checkevent (menu-window men)))
       (ret nil)
       (nth-menu nil))
      (ret ret)
      ;; (prind event)
      (cond ((eq 'ButtonPress (first event))
	     (setq nth-menu (// (fourth event) 16))
	     (if (< nth-menu (length (menu-items men)))
		 (setq ret (nth nth-menu (menu-items men))))))))

(comment (setq lang-menu 
	       (create-menu "Language" 
			    '(("えーぴーえる" APL) 
			      ("りすぷ" Lisp)
			      ("ふぉーとらん" Fortran)
			      ("ぱすかる" Pascal))))
	 (loop (print (select-menu lang-menu))))

(setq now-jitai 'mincho)
(setq now-width 20.0
      max-width 40.0
      min-width 5.0)
(setq now-selected nil)

(setq -number-str-juu- "＿１２３４５６７８９０")
(setq -number-str-iti- "０１２３４５６７８９０")
(defun width2str ()
  (let ((wid (fix now-width)))
    (cond ((or (< wid (fix min-width)) (> wid (fix max-width))) "？？")
	  (t (let ((juu (remainder (quotient wid 10) 10))
		   (iti (remainder wid 10)))
	       (string-append (substring -number-str-juu-
					 (* juu 2) (+ 2 (* juu 2)))
			      (substring -number-str-iti-
					 (* iti 2) (+ 2 (* iti 2)))))))))

(defun redraw-status ()
  (smallwindow-clear status-window)
  (smallwindow-putstr status-window 0 16
		      (string-append "字体＿＿＿＿＿" 
				     (cond ((eq now-jitai 'mincho)
					    "明朝")
					   ((eq now-jitai 'gothic)
					    "ゴシック")
					   (t "不明"))))
  (smallwindow-putstr status-window 0 32
		      (string-append "幅の係数＿＿＿" (width2str)))
  (smallwindow-putstr status-window 0 48
		      (string-append "漢字＿＿＿＿＿「" 
				     (if now-selected now-selected "？") 
				     "」"))
  (smallwindow-redraw status-window))

;; 漢字フォントを表示してみる

(defun smallwindow-display-kanji-font (sw l tag)
  (let ((outline (skelton2list (applykanji l) tag)))
    (smallwindow-clear sw)
    (mapcar outline '(lambda (x) (smallwindow-fillpolygon sw (setpart1 x))))
    (smallwindow-redraw sw)))

(defun display-kanji-font (l tag)
  (princ "表示の計算中 ")
  (smallwindow-display-kanji-font hyouji l tag)
  (smallwindow-redraw hyouji)
  (prind "終了"))

;; メインの作業

(defun make-windows ()
  (setq kanji-itiran (create-smallwindow window-of-menus "kanzi itiran" (* 14 16) (+ (* 14 6) 3)))
  (setq jitai-etc-menu 
	(create-menu "zitai"
		     '(("明朝"       mincho)
		       ("ゴシック"   gothic)
		       ("幅を増やす" incr-width)
		       ("幅を減らす" decr-width)
		       ("再表示"     re-display)
		       ("次の字"     next-select))
		     80))
  (setq status-window 
	(create-smallwindow window-of-menus "zyoutai" 180 54))
  (setq hyouji (create-smallwindow root "hyouzi")))

(defun main ()
  (make-windows)
  (redraw-status)
  (do ()
      (nil nil)
      (select-kanji)
      (redraw-status)
      (display-kanji-font (intern now-selected) now-jitai)
      
      (do ((key (second (select-menu jitai-etc-menu))
		(second (select-menu jitai-etc-menu))))
	  ((eq key 'next-select) 
	   (progn (princ "next-select")
		  (setq now-selected nil)
		  (redraw-status)))
	  (princ key) (princ " ")
	  (cond ((eq key 'mincho) (setq now-jitai 'mincho))
		((eq key 'gothic) (setq now-jitai 'gothic))
		((eq key 'incr-width) (setq now-width (+$ now-width 1.0)))
		((eq key 'decr-width) (setq now-width (-$ now-width 1.0))))
	  (if (<$ now-width min-width) (setq now-width min-width))
	  (if (>$ now-width max-width) (setq now-width max-width))
	  (setq minchowidth now-width 
		gothicwidth now-width)
	  
	  (if (eq key 're-display)
	      (display-kanji-font (intern now-selected) now-jitai)
	    (redraw-status)))))