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