View of /lisp/demo/demo.l

Parent Directory

Revision Log

Initial revision

;; Local Variables:
;;   kanji-fileio-code: 3
;; end:
;;
;; kanji demo program
;; 漢字文字列をベクタに変換
(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 のロード
;; Note: load defined in loadulx.l

(defun init_window () 'dummy)

(unless (definedp 'applykanji)
;       (load "./pack.l")
;       (load "./all.l")
;       (load "./disp.l")
;       (load "./mincho.l")
;       (load "./gothic.l")
;       (load "./lib.l")
;       (load "./joint.l")
	(load "./newload.l")
)

(setq *all-smallwindows* nil)

;; ウィンドウを作ってみる
(defstruct (smallwindow)
  window
  save
  name					;window name
  gc
  revgc
  height
  width)

(defun create-smallwindow (parent name x y wid hei
				  (gc blackgc) (revgc whitegc))
  (lets ((a (make-smallwindow
	     :window (create-window
		      :parent parent
		      :class  :input-output
		      :x x
		      :y y
		      :width wid
		      :height hei
		      :foreground black
		      :background white
		      :border-width 1 
		      :event-mask '(:button-press :button-release
				    :key-press :exposure))
	     :save   (create-pixmap
		      :width wid
		      :height hei
		      :drawable root
		      :depth 1)
	     :name name
	     :gc gc
	     :revgc revgc
	     :width wid
	     :height hei)))
    (smallwindow-clear 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))

;; イベントのチェック
(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)
;  (or (mem (function (lambda (x y) (eq (smallwindow-window y) x)))
;	   event-window
;	   *all-smallwindows*)
;      (and (print "??? display:error") nil)))
		       
(defun search-smallwindow (event-window)
  (do ((rest *all-smallwindows* (cdr rest)))
      ((atom rest) (print "??? display:error") nil)
      (and (eq (smallwindow-window (car rest)) event-window)
	   (exit (car rest)))))
       
	  
;; 歴史的な理由による関数群
(defun cons2flat (points)
  (mapcon points
          (function (lambda (l) (list (caar l) (cdar l))))))

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

(defun display-kanji (start)
  (let ((high start))
    (cond ((< high min-kanji-high) (setq high min-kanji-high))
	  ((> high max-kanji-high) (setq high max-kanji-high)))
    (and (<> kanji-itiran-high high)
	 (let ((str (make-string 32)))
	   (smallwindow-clear kanji-itiran)
	   (setq kanji-itiran-high high)

	   (do ((low 32)
		(disp-y 14 (+ 14 disp-y)))
	       ((> low 126))
	     (do ((index 0 (+ index 2)))
		 ((>= index 32))
	       (selectq low
		 (32
		  (string-amend str
				(cond ((<= kanji-itiran-high min-kanji-high)
				       "＿")
				      (t "＜"))
				0))
		 (127
		  (string-amend str
				(cond ((>= kanji-itiran-high max-kanji-high)
				       "＿")
				      (t "＞"))
				30))
		 (t (sset str index high)
		    (sset str (1+ index) low)))
	       (setq low (1+ low)))
	     (smallwindow-putstr kanji-itiran 0 disp-y str)))))
  (smallwindow-redraw kanji-itiran))
  
;; メニューを作る
;; 呼び出し方法 (setq lang-menu (create-menu "Language" 
;;                          '(("ＡＰＬ" APL) ("Ｌｉｓｐ" Lisp))))
;;              (select-menu lang-menu)
;; 結果          =>   ("ＡＰＬ" APL) か ("Ｌｉｓｐ" Lisp)

(defstruct (menu)
  window
  items
)

(defun create-menu (parent title item-list x y (width 200))
  (let ((sw (make-menu
	     :window (create-smallwindow parent
					 title
					 x y
					 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 get-menu-entry (men x y)
  (let ((nth-menu (// y 16)))
    (and (< nth-menu (length (menu-items men)))
	 (nth nth-menu (menu-items men)))))


(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 "字体＿＿＿＿＿" 
				     (selectq now-jitai
				       (mincho "明朝")
				       (gothic "ゴシック")
				       (t "不明"))))
  (smallwindow-putstr status-window 0 32
		      (string-append "幅の係数＿＿＿" (width2str)))
  (smallwindow-putstr status-window 0 48
		      (string-append "漢字＿＿＿＿＿「" 
				     (or now-selected "？") 
				     "」"))
  (smallwindow-redraw status-window))

;;
(setq lastkanji nil)
(setq lastapply nil)
(defun cache-applykanji (kanji)
  (cond ((eq lastkanji kanji)
	 lastapply)
	(t
	 (setq lastkanji kanji)
	 (setq lastapply (applykanji kanji)))))
;; 漢字フォントを表示してみる

(defun smallwindow-display-kanji-font (sw l tag)
  (let ((outline (skelton2list (cache-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 basepane
	(create-window :parent root
		       :x 0 :y 0
		       :width 400 :height 600
		       :class :input-output
		       :foreground black
		       :background white))
  (setf (wm-name basepane) "kanjidemo")

  (setq kanji-itiran
	(create-smallwindow basepane 'select-kanji
			    0 60
			    (* 14 16) (+ (* 14 6) 3)))
  (setq jitai-etc-menu 
	(create-menu basepane 'zitai
		     '(("明朝"       mincho)
		       ("ゴシック"   gothic)
		       ("太くする" incr-width)
		       ("細くする" decr-width)
		       ("再表示"     re-display))
		     (+ (* 14 16) 8) 60
		     80))
  (setq status-window 
	(create-smallwindow basepane 'zyoutai
			    0 0 180 54))
  (setq hyouji
	(create-smallwindow basepane 'hyouzi 0 200 400 400))
  
  (map-subwindows basepane)
  (map-window basepane)
  (display-force-output display))

(setq display-host (get-display-host))
(or display-host (progn (format "Display unknown/n") (err:argument-type)))

(defun handle-events ()
  (event-case (display)
	      (:exposure (event-window count)
	       (let ((kouho (search-smallwindow event-window)))
		 (and (0= count) (smallwindow-redraw kouho)))
	       t)
	      (:button-press (event-window code x y)
	       (let ((sw (search-smallwindow event-window)))
		 (selectq (smallwindow-name sw)
		   (select-kanji (handle-select-kanji x y))
		   (zitai (handle-set-jitai x y))
		   ))
	       t)
	      (otherwise ()
	       t)))

(defun handle-set-jitai (x y)
  (let ((ent (get-menu-entry jitai-etc-menu x y)))
    (cond (ent
      (selectq (second ent)
	(mincho (setq now-jitai 'mincho))
	(gothic (setq now-jitai 'gothic))
	(incr-width (let ((w (+$ now-width 1.0)))
		      (and (<=$ w max-width) (setq now-width w))))
	(decr-width (let ((w (-$ now-width 1.0)))
		      (and (>=$ w min-width) (setq now-width w))))
	(re-display (cond (now-selected
			   (display-kanji-font (intern now-selected) now-jitai)
			   )))
	)
      (setq minchowidth now-width
	    gothicwidth now-width)
      (redraw-status)))))

;; x y - clicked position
(defun handle-select-kanji (x y)
  (display-kanji kanji-itiran-high)
  (let ((low-nth (+ (// x 14) (* (// y 14) 16))))
    (princ " ") (princ low-nth)
    (cond ((and (< low-nth 95) (> low-nth 0))
	   (setq now-selected (string-append (string (+ kanji-itiran-high 128))
				    (string (+ low-nth 128 33 -1))))
	   (display-kanji-font (intern now-selected) now-jitai)
	   (redraw-status))
	  (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))))))))

(defun setup-display ()
;; スクリーンの定義
  (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))

  (setq kanjifont (open-font display "k14")
	asciifont (open-font display "a14"))

  (setq whitegc (create-gcontext
		 :drawable root
		 :foreground white
		 :background black
		 :font kanjifont)
	
	blackgc (create-gcontext
		 :drawable root
		 :foreground black 
		 :background white
		 :font kanjifont))
  )

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

(defun main ()
  (setq now-jitai 'mincho)
  (setq now-width 20.0
	max-width 40.0
	min-width 5.0)
  (setq now-selected nil)
  (setup-display)
  (make-windows)
  (display-kanji kanji-itiran-high)
  (redraw-status)
  (loop (handle-events)))