View of /lisp/tools/message.l

Parent Directory

Revision Log

change to CVS wadalab font project

;; --------- ;;
;; message.l ;;
;; --------- ;;

;; 文字を出力するとスクロールするウィンドウ
(defun is-kanji (code)
  (= (logand 128 code) 128))

(defun scroll-up-win (win up)
  (comment print (list 'scroll up))
  (let ((wid (get-winprop win 'width))
	(hei (get-winprop win 'height))
	(gc  (get-winprop win 'saveblackgc))
	(wgc (get-winprop win 'savewhitegc))
	(pix (get-winprop win 'save)))
    (copy-plane pix gc 1
		0 up wid (- hei up)
		pix 0 0)
    (draw-rectangle pix wgc
		    0 (- hei up)
		    wid up t)))

(defun scroll-down-win (win down)
  (let ((wid (get-winprop win 'width))
	(hei (get-winprop win 'height))
	(gc  (get-winprop win 'saveblackgc))
	(wgc (get-winprop win 'savewhitegc))
	(pix (get-winprop win 'save)))
    (copy-plane pix gc 1
		0 0 wid (- hei down)
		pix 0 down)
    (draw-rectangle pix wgc
		    0 0
		    wid down t)))

(defun scroll-win (win up-down)
  (if (minusp up-down)
      (scroll-down-win win (minus up-down))
    (scroll-up-win win up-down)))

(defun print-message-win (win string)
  (princ-message-win win string t))

(defun princ-message-win (win string (lf nil))
  (let* ((length (string-length string))
	 (high nil) (low nil) (str "") (nstr "")
	 (font   (gcontext-font (get-winprop win 'blackgc)))
	 (ascent (+ (font-ascent font) 2))
	 (descent (font-descent font))
	 (now-x  (get-winprop win 'now-x))
	 (last-x (- (get-winprop win 'width) 2))
	 (now-y  (get-winprop win 'now-y))
	 (last-y (- (get-winprop win 'height) ascent descent))
	 (kanji nil)
	 (left t)
	 (next-x nil) (next-y nil)
	 (dx nil))
    (unless now-x (setq now-x 0))
    (unless now-y (setq now-y 0))
    (setq next-x now-x next-y now-y)

    (do ((i 0))
	((or (>= i length) (not left)))
	(setq str "")
	(comment print (list now-x now-y))
	(loop
	 (if (>= i length) (exit))
	 (setq kanji (is-kanji (sref string i)))
	 (setq nstr (if kanji (substring string i (+ i 2)) ""))
	 (setq dx (text-width font
			      (string-append str nstr)))
	 (when (>= (setq next-x (+ now-x dx)) last-x)
	   (setq next-x 0)
	   (setq next-y (+ now-y ascent descent))
	   (exit))

	 (setq str (string-append str nstr))
	 (setq i (+ i (if kanji 2 1))))

	(comment print (list now-x now-y last-y))
	(draw-string16-win win str (+ now-x 2) (+ now-y ascent))
	(when (>= next-y last-y) 
	  (scroll-up-win win (+ ascent descent))
	  (setq next-y now-y))

	(setq now-x next-x)
	(setq now-y next-y)

	(comment print (list now-x now-y last-y)))

    (when lf 
      (setq now-x 0)
      (setq next-y (+ now-y ascent descent))
      (when (>= next-y last-y)
	(scroll-up-win win (+ ascent descent))
	(setq next-y now-y))
      (setq now-y next-y))

    (redraw-win win)
    (display-force-output (window-display win))
    

    (put-winprop win 'now-x now-x)
    (put-winprop win 'now-y now-y)))