View of /skeleton-edit/skel-lib.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; skel-lib.l (for compile)
;;


;; ------------------------------------------------------ ;;
;; this function used in draw-glyphs (string16 -> vector) ;;
;; ------------------------------------------------------ ;;
(comment defun kanji2vec (str)
	 (comment
	  (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)))))))))
	 str)

;; ----------------------------------------- ;;
;; functions in order to access window-plist ;;
;; ----------------------------------------- ;;
(defun get-winprop (win key)
  (let ((al (assq key (window-plist win))))
    (and al (cadr al))))

(defun put-winprop (win key value)
  (let ((al (assq key (window-plist win))))
    (cond (al (rplacd al (list value)))
	  (t 
	   (setf (window-plist win) 
		 (cons (list key value) (window-plist win)))))))

;; --------------------------------------------- ;;
;; create windows with pixmap-for-save and so on ;;
;; --------------------------------------------- ;;
(defun redraw-win (win)
  ;; (print (get-winprop win 'highlighten))
  (copy-plane (get-winprop win 'save) 
	      (selectq (get-winprop win 'highlighten) 
		       (yes (get-winprop win 'reversegc))
		       (no  (get-winprop win 'blackgc)))
	      1 0 0 
	      (get-winprop win 'width) 
	      (get-winprop win 'height)
	      win 0 0))

(defun draw-string16-win (win str x y)
  (draw-glyphs (get-winprop win 'save)
	       (get-winprop win 'saveblackgc)
	       x y
	       str
	       :size 16))

; tanaka 1993/9/19
(declare (grid-dots) special)
(setq grid-dots nil)
(defun grid-win (win)
  (draw-rectangle (get-winprop win 'save)
		  (get-winprop win 'blackgc)
		  15 15 
		  (- (get-winprop win 'width) 30)
		  (- (get-winprop win 'height) 30))
  (draw-line (get-winprop win 'save)
	     (get-winprop win 'blackgc)
	     200 0 200 400)
  (draw-line (get-winprop win 'save)
	     (get-winprop win 'blackgc)
	     0 200 400 200)
  (or grid-dots
      (do ((x 10 (+ x 10)))
	((>= x 400))
	(do ((y 10 (+ y 10)))
	  ((>= y 400))
	  (push y grid-dots)
	  (push x grid-dots))))
  (draw-points (get-winprop win 'save)
	       (get-winprop win 'xorgc)
	       grid-dots))
(defun clear-win (win)
  (draw-rectangle (get-winprop win 'save)
		  (get-winprop win 'savewhitegc)
		  0 0 
		  (get-winprop win 'width) 
		  (get-winprop win 'height) t)
  (put-winprop win 'now-x 0)
  (put-winprop win 'now-y 0))

;; ----------------------- ;;
;; create menu item window ;;
;; ----------------------- ;;
(defun create-menu-item-win (parent str x y black white font cursor)
  (lets	((as (font-ascent font))
	 (de (font-descent font))
	 (wid (+ (text-width font str) (* 2 *menu-margin*)))
	 (hei (+ as de (* 2 *menu-margin*)))
	 (mw (create-win parent x y wid hei black white font)))
	
	(setf (window-border mw) 0)
	(setf (window-event-mask mw) '(:exposure 
				       :button-press
				       :enter-window   :leave-window))
	(setf (window-cursor mw) cursor)

	(put-winprop mw 'enter-notify-handler (function draw-frame-win))
	(put-winprop mw 'leave-notify-handler (function erase-frame-win))
	(put-winprop mw 'display-string str)
	(draw-string16-win mw str *menu-margin* (+ as *menu-margin*))
	
	mw))

;; ----------------------------------- ;;
;; when pointer enters/leaves a window ;;
;; ----------------------------------- ;;
(defun draw-frame-win (win)
  (draw-rectangle win 
		  (selectq (get-winprop win 'highlighten) 
			   (yes (get-winprop win 'whitegc))
			   (no  (get-winprop win 'blackgc)))
		  0 0 
		  (- (get-winprop win 'width)  1) 
		  (- (get-winprop win 'height) 2)))

(defun erase-frame-win (win)
  (draw-rectangle win 
		  (selectq (get-winprop win 'highlighten)
			   (yes (get-winprop win 'blackgc))
			   (no  (get-winprop win 'whitegc)))
		  0 0
		  (- (get-winprop win 'width)  1) 
		  (- (get-winprop win 'height) 2)))

;; ----------------------- ;;
;; highlight/normal window ;;
;; ----------------------- ;;
(defun highlight-win (win)
  (put-winprop win 'highlighten 'yes)
  (redraw-win win))

(defun normal-win (win)
  (put-winprop win 'highlighten 'no)
  (redraw-win win))

;; -------------------- ;;
;; called in event-loop ;; 
;; -------------------- ;;
(defun handle-exposure (win)
  (let ((func (get-winprop win 'exposure-handler)))
    (and func (funcall func win))))

(defun handle-enter-notify (win)
  (let ((func (get-winprop win 'enter-notify-handler)))
    (and func (funcall func win))))

(defun handle-leave-notify (win)
  (let ((func (get-winprop win 'leave-notify-handler)))
    (and func (funcall func win))))

(defun handle-button-release (win code x y)
  (let ((func (get-winprop win 'button-release-handler)))
    (and func (funcall func win code x y))))

(defun handle-button-press (win code x y)
  (let ((func (get-winprop win 'button-press-handler)))
    (and func (funcall func win code x y))))

(defun handle-motion-notify (win x y)
  (let ((func (get-winprop win 'motion-notify-handler)))
    (and func (funcall func win x y))))

;; ------------- ;;
;; create window ;;
;; ------------- ;;
(defun create-win (parent x y width height black white font)
  (lets ((win (create-window :parent     parent
			     :class      ':input-output
			     :x x        :y y
			     :width      width
			     :height     height
			     :foreground black
			     :background white
			     :event-mask '(:exposure)
			     :border-width 1))
	 
	 (pix (create-pixmap :drawable parent
			     :width    width
			     :height   height
			     :depth    default-depth))

	 (blackgc root-blackgc)
	 (whitegc root-whitegc)
	 (reversegc root-reversegc)
	 (xorgc root-xorgc)
	 (dashlinegc root-dashlinegc)
	 (saveblackgc root-saveblackgc)
	 (savewhitegc root-savewhitegc))

    
    (draw-rectangle pix savewhitegc 0 0 width height t)
    
    (put-winprop win 'width  width)
    (put-winprop win 'height height)
    
    (put-winprop win 'blackgc blackgc)
    (put-winprop win 'whitegc whitegc)
    (put-winprop win 'reversegc reversegc)
    (put-winprop win 'xorgc xorgc)
    (put-winprop win 'dashlinegc dashlinegc)
    
    (put-winprop win 'save pix)
    (put-winprop win 'saveblackgc saveblackgc)
    (put-winprop win 'savewhitegc savewhitegc)
    
    (put-winprop win 'now-x 0)
    (put-winprop win 'now-y 0)
    
    (put-winprop win 'highlighten 'no)
    (put-winprop win 'exposure-handler (function redraw-win))
    win))

;; ------------- ;;
;; window resize ;;
;; ------------- ;;
(defun resize-win (win width (height (get-winprop win 'height)))
  (lets ((oldsave (get-winprop win 'save))
	 (newsave (create-pixmap :drawable win
				 :width    width
				 :height   height
				 :depth    default-depth)))
	(draw-rectangle newsave (get-winprop win 'savewhitegc)
			0 0 width height t)
	
	(copy-plane oldsave 
		    (get-winprop win 'saveblackgc)
		    1 0 0
		    (max width  (get-winprop win 'width))
		    (max height (get-winprop win 'height))
		    newsave 0 0)
	
	(put-winprop win 'save newsave)
	(free-pixmap oldsave))
  
  (setf (drawable-width win) width)
  (setf (drawable-height win) height)
  (put-winprop win 'width  width)
  (put-winprop win 'height height))

;; --------------------------------- ;;
;; make some length some filler list ;;
;; --------------------------------- ;;
(defun make-list (length (filler nil))
  (do ((i 0 (1+ i))
       (ret nil))
      ((>= i length) ret)
      (push filler ret)))

;; -------- ;;
;; get-info ;;
;; -------- ;;
(defun get-info (point-or-line key)
  (let ((info (assq key (cddr point-or-line))))
    (if info
	(cdr info)
      nil)))

;; -------- ;;
;; put-info ;;
;; -------- ;;
(defun put-info (point-or-line key new-info)
  (let ((info (assq key (cddr point-or-line))))
    (if info
	(setf (cdr info) new-info)
      (nconc point-or-line (ncons (cons key new-info)))))
  point-or-line)

;; -------- ;;
;; rem-info ;;
;; -------- ;;
(defun rem-info (point-or-line key)
  (setf (cddr point-or-line)
	(mapcan (cddr point-or-line)
		#'(lambda (x)
		    (if (eq (first x) key)
			nil
		      (ncons x)))))
  point-or-line)