| 1 : |
ktanaka |
1.1 |
;; |
| 2 : |
|
|
;; skel-lib.l (for compile) |
| 3 : |
|
|
;; |
| 4 : |
|
|
|
| 5 : |
|
|
|
| 6 : |
|
|
;; ------------------------------------------------------ ;; |
| 7 : |
|
|
;; this function used in draw-glyphs (string16 -> vector) ;; |
| 8 : |
|
|
;; ------------------------------------------------------ ;; |
| 9 : |
|
|
(comment defun kanji2vec (str) |
| 10 : |
|
|
(comment |
| 11 : |
|
|
(lets ((len (// (string-length str) 2)) |
| 12 : |
|
|
(vec (vector len))) |
| 13 : |
|
|
(do ((i 0 (1+ i))) |
| 14 : |
|
|
((>= i len)vec) |
| 15 : |
|
|
(vset vec i (+ (* 256 (logand 127 (sref str (* 2 i)))) |
| 16 : |
|
|
(logand 127 (sref str (1+ (* 2 i))))))))) |
| 17 : |
|
|
str) |
| 18 : |
|
|
|
| 19 : |
|
|
;; ----------------------------------------- ;; |
| 20 : |
|
|
;; functions in order to access window-plist ;; |
| 21 : |
|
|
;; ----------------------------------------- ;; |
| 22 : |
|
|
(defun get-winprop (win key) |
| 23 : |
|
|
(let ((al (assq key (window-plist win)))) |
| 24 : |
|
|
(and al (cadr al)))) |
| 25 : |
|
|
|
| 26 : |
|
|
(defun put-winprop (win key value) |
| 27 : |
|
|
(let ((al (assq key (window-plist win)))) |
| 28 : |
|
|
(cond (al (rplacd al (list value))) |
| 29 : |
|
|
(t |
| 30 : |
|
|
(setf (window-plist win) |
| 31 : |
|
|
(cons (list key value) (window-plist win))))))) |
| 32 : |
|
|
|
| 33 : |
|
|
;; --------------------------------------------- ;; |
| 34 : |
|
|
;; create windows with pixmap-for-save and so on ;; |
| 35 : |
|
|
;; --------------------------------------------- ;; |
| 36 : |
|
|
(defun redraw-win (win) |
| 37 : |
|
|
;; (print (get-winprop win 'highlighten)) |
| 38 : |
|
|
(copy-plane (get-winprop win 'save) |
| 39 : |
|
|
(selectq (get-winprop win 'highlighten) |
| 40 : |
|
|
(yes (get-winprop win 'reversegc)) |
| 41 : |
|
|
(no (get-winprop win 'blackgc))) |
| 42 : |
|
|
1 0 0 |
| 43 : |
|
|
(get-winprop win 'width) |
| 44 : |
|
|
(get-winprop win 'height) |
| 45 : |
|
|
win 0 0)) |
| 46 : |
|
|
|
| 47 : |
|
|
(defun draw-string16-win (win str x y) |
| 48 : |
|
|
(draw-glyphs (get-winprop win 'save) |
| 49 : |
|
|
(get-winprop win 'saveblackgc) |
| 50 : |
|
|
x y |
| 51 : |
|
|
str |
| 52 : |
|
|
:size 16)) |
| 53 : |
|
|
|
| 54 : |
|
|
; tanaka 1993/9/19 |
| 55 : |
|
|
(declare (grid-dots) special) |
| 56 : |
|
|
(setq grid-dots nil) |
| 57 : |
|
|
(defun grid-win (win) |
| 58 : |
|
|
(draw-rectangle (get-winprop win 'save) |
| 59 : |
|
|
(get-winprop win 'blackgc) |
| 60 : |
|
|
15 15 |
| 61 : |
|
|
(- (get-winprop win 'width) 30) |
| 62 : |
|
|
(- (get-winprop win 'height) 30)) |
| 63 : |
|
|
(draw-line (get-winprop win 'save) |
| 64 : |
|
|
(get-winprop win 'blackgc) |
| 65 : |
|
|
200 0 200 400) |
| 66 : |
|
|
(draw-line (get-winprop win 'save) |
| 67 : |
|
|
(get-winprop win 'blackgc) |
| 68 : |
|
|
0 200 400 200) |
| 69 : |
|
|
(or grid-dots |
| 70 : |
|
|
(do ((x 10 (+ x 10))) |
| 71 : |
|
|
((>= x 400)) |
| 72 : |
|
|
(do ((y 10 (+ y 10))) |
| 73 : |
|
|
((>= y 400)) |
| 74 : |
|
|
(push y grid-dots) |
| 75 : |
|
|
(push x grid-dots)))) |
| 76 : |
|
|
(draw-points (get-winprop win 'save) |
| 77 : |
|
|
(get-winprop win 'xorgc) |
| 78 : |
|
|
grid-dots)) |
| 79 : |
|
|
(defun clear-win (win) |
| 80 : |
|
|
(draw-rectangle (get-winprop win 'save) |
| 81 : |
|
|
(get-winprop win 'savewhitegc) |
| 82 : |
|
|
0 0 |
| 83 : |
|
|
(get-winprop win 'width) |
| 84 : |
|
|
(get-winprop win 'height) t) |
| 85 : |
|
|
(put-winprop win 'now-x 0) |
| 86 : |
|
|
(put-winprop win 'now-y 0)) |
| 87 : |
|
|
|
| 88 : |
|
|
;; ----------------------- ;; |
| 89 : |
|
|
;; create menu item window ;; |
| 90 : |
|
|
;; ----------------------- ;; |
| 91 : |
|
|
(defun create-menu-item-win (parent str x y black white font cursor) |
| 92 : |
|
|
(lets ((as (font-ascent font)) |
| 93 : |
|
|
(de (font-descent font)) |
| 94 : |
|
|
(wid (+ (text-width font str) (* 2 *menu-margin*))) |
| 95 : |
|
|
(hei (+ as de (* 2 *menu-margin*))) |
| 96 : |
|
|
(mw (create-win parent x y wid hei black white font))) |
| 97 : |
|
|
|
| 98 : |
|
|
(setf (window-border mw) 0) |
| 99 : |
|
|
(setf (window-event-mask mw) '(:exposure |
| 100 : |
|
|
:button-press |
| 101 : |
|
|
:enter-window :leave-window)) |
| 102 : |
|
|
(setf (window-cursor mw) cursor) |
| 103 : |
|
|
|
| 104 : |
|
|
(put-winprop mw 'enter-notify-handler (function draw-frame-win)) |
| 105 : |
|
|
(put-winprop mw 'leave-notify-handler (function erase-frame-win)) |
| 106 : |
|
|
(put-winprop mw 'display-string str) |
| 107 : |
|
|
(draw-string16-win mw str *menu-margin* (+ as *menu-margin*)) |
| 108 : |
|
|
|
| 109 : |
|
|
mw)) |
| 110 : |
|
|
|
| 111 : |
|
|
;; ----------------------------------- ;; |
| 112 : |
|
|
;; when pointer enters/leaves a window ;; |
| 113 : |
|
|
;; ----------------------------------- ;; |
| 114 : |
|
|
(defun draw-frame-win (win) |
| 115 : |
|
|
(draw-rectangle win |
| 116 : |
|
|
(selectq (get-winprop win 'highlighten) |
| 117 : |
|
|
(yes (get-winprop win 'whitegc)) |
| 118 : |
|
|
(no (get-winprop win 'blackgc))) |
| 119 : |
|
|
0 0 |
| 120 : |
|
|
(- (get-winprop win 'width) 1) |
| 121 : |
|
|
(- (get-winprop win 'height) 2))) |
| 122 : |
|
|
|
| 123 : |
|
|
(defun erase-frame-win (win) |
| 124 : |
|
|
(draw-rectangle win |
| 125 : |
|
|
(selectq (get-winprop win 'highlighten) |
| 126 : |
|
|
(yes (get-winprop win 'blackgc)) |
| 127 : |
|
|
(no (get-winprop win 'whitegc))) |
| 128 : |
|
|
0 0 |
| 129 : |
|
|
(- (get-winprop win 'width) 1) |
| 130 : |
|
|
(- (get-winprop win 'height) 2))) |
| 131 : |
|
|
|
| 132 : |
|
|
;; ----------------------- ;; |
| 133 : |
|
|
;; highlight/normal window ;; |
| 134 : |
|
|
;; ----------------------- ;; |
| 135 : |
|
|
(defun highlight-win (win) |
| 136 : |
|
|
(put-winprop win 'highlighten 'yes) |
| 137 : |
|
|
(redraw-win win)) |
| 138 : |
|
|
|
| 139 : |
|
|
(defun normal-win (win) |
| 140 : |
|
|
(put-winprop win 'highlighten 'no) |
| 141 : |
|
|
(redraw-win win)) |
| 142 : |
|
|
|
| 143 : |
|
|
;; -------------------- ;; |
| 144 : |
|
|
;; called in event-loop ;; |
| 145 : |
|
|
;; -------------------- ;; |
| 146 : |
|
|
(defun handle-exposure (win) |
| 147 : |
|
|
(let ((func (get-winprop win 'exposure-handler))) |
| 148 : |
|
|
(and func (funcall func win)))) |
| 149 : |
|
|
|
| 150 : |
|
|
(defun handle-enter-notify (win) |
| 151 : |
|
|
(let ((func (get-winprop win 'enter-notify-handler))) |
| 152 : |
|
|
(and func (funcall func win)))) |
| 153 : |
|
|
|
| 154 : |
|
|
(defun handle-leave-notify (win) |
| 155 : |
|
|
(let ((func (get-winprop win 'leave-notify-handler))) |
| 156 : |
|
|
(and func (funcall func win)))) |
| 157 : |
|
|
|
| 158 : |
|
|
(defun handle-button-release (win code x y) |
| 159 : |
|
|
(let ((func (get-winprop win 'button-release-handler))) |
| 160 : |
|
|
(and func (funcall func win code x y)))) |
| 161 : |
|
|
|
| 162 : |
|
|
(defun handle-button-press (win code x y) |
| 163 : |
|
|
(let ((func (get-winprop win 'button-press-handler))) |
| 164 : |
|
|
(and func (funcall func win code x y)))) |
| 165 : |
|
|
|
| 166 : |
|
|
(defun handle-motion-notify (win x y) |
| 167 : |
|
|
(let ((func (get-winprop win 'motion-notify-handler))) |
| 168 : |
|
|
(and func (funcall func win x y)))) |
| 169 : |
|
|
|
| 170 : |
|
|
;; ------------- ;; |
| 171 : |
|
|
;; create window ;; |
| 172 : |
|
|
;; ------------- ;; |
| 173 : |
|
|
(defun create-win (parent x y width height black white font) |
| 174 : |
|
|
(lets ((win (create-window :parent parent |
| 175 : |
|
|
:class ':input-output |
| 176 : |
|
|
:x x :y y |
| 177 : |
|
|
:width width |
| 178 : |
|
|
:height height |
| 179 : |
|
|
:foreground black |
| 180 : |
|
|
:background white |
| 181 : |
|
|
:event-mask '(:exposure) |
| 182 : |
|
|
:border-width 1)) |
| 183 : |
|
|
|
| 184 : |
|
|
(pix (create-pixmap :drawable parent |
| 185 : |
|
|
:width width |
| 186 : |
|
|
:height height |
| 187 : |
|
|
:depth default-depth)) |
| 188 : |
|
|
|
| 189 : |
|
|
(blackgc root-blackgc) |
| 190 : |
|
|
(whitegc root-whitegc) |
| 191 : |
|
|
(reversegc root-reversegc) |
| 192 : |
|
|
(xorgc root-xorgc) |
| 193 : |
|
|
(dashlinegc root-dashlinegc) |
| 194 : |
|
|
(saveblackgc root-saveblackgc) |
| 195 : |
|
|
(savewhitegc root-savewhitegc)) |
| 196 : |
|
|
|
| 197 : |
|
|
|
| 198 : |
|
|
(draw-rectangle pix savewhitegc 0 0 width height t) |
| 199 : |
|
|
|
| 200 : |
|
|
(put-winprop win 'width width) |
| 201 : |
|
|
(put-winprop win 'height height) |
| 202 : |
|
|
|
| 203 : |
|
|
(put-winprop win 'blackgc blackgc) |
| 204 : |
|
|
(put-winprop win 'whitegc whitegc) |
| 205 : |
|
|
(put-winprop win 'reversegc reversegc) |
| 206 : |
|
|
(put-winprop win 'xorgc xorgc) |
| 207 : |
|
|
(put-winprop win 'dashlinegc dashlinegc) |
| 208 : |
|
|
|
| 209 : |
|
|
(put-winprop win 'save pix) |
| 210 : |
|
|
(put-winprop win 'saveblackgc saveblackgc) |
| 211 : |
|
|
(put-winprop win 'savewhitegc savewhitegc) |
| 212 : |
|
|
|
| 213 : |
|
|
(put-winprop win 'now-x 0) |
| 214 : |
|
|
(put-winprop win 'now-y 0) |
| 215 : |
|
|
|
| 216 : |
|
|
(put-winprop win 'highlighten 'no) |
| 217 : |
|
|
(put-winprop win 'exposure-handler (function redraw-win)) |
| 218 : |
|
|
win)) |
| 219 : |
|
|
|
| 220 : |
|
|
;; ------------- ;; |
| 221 : |
|
|
;; window resize ;; |
| 222 : |
|
|
;; ------------- ;; |
| 223 : |
|
|
(defun resize-win (win width (height (get-winprop win 'height))) |
| 224 : |
|
|
(lets ((oldsave (get-winprop win 'save)) |
| 225 : |
|
|
(newsave (create-pixmap :drawable win |
| 226 : |
|
|
:width width |
| 227 : |
|
|
:height height |
| 228 : |
|
|
:depth default-depth))) |
| 229 : |
|
|
(draw-rectangle newsave (get-winprop win 'savewhitegc) |
| 230 : |
|
|
0 0 width height t) |
| 231 : |
|
|
|
| 232 : |
|
|
(copy-plane oldsave |
| 233 : |
|
|
(get-winprop win 'saveblackgc) |
| 234 : |
|
|
1 0 0 |
| 235 : |
|
|
(max width (get-winprop win 'width)) |
| 236 : |
|
|
(max height (get-winprop win 'height)) |
| 237 : |
|
|
newsave 0 0) |
| 238 : |
|
|
|
| 239 : |
|
|
(put-winprop win 'save newsave) |
| 240 : |
|
|
(free-pixmap oldsave)) |
| 241 : |
|
|
|
| 242 : |
|
|
(setf (drawable-width win) width) |
| 243 : |
|
|
(setf (drawable-height win) height) |
| 244 : |
|
|
(put-winprop win 'width width) |
| 245 : |
|
|
(put-winprop win 'height height)) |
| 246 : |
|
|
|
| 247 : |
|
|
;; --------------------------------- ;; |
| 248 : |
|
|
;; make some length some filler list ;; |
| 249 : |
|
|
;; --------------------------------- ;; |
| 250 : |
|
|
(defun make-list (length (filler nil)) |
| 251 : |
|
|
(do ((i 0 (1+ i)) |
| 252 : |
|
|
(ret nil)) |
| 253 : |
|
|
((>= i length) ret) |
| 254 : |
|
|
(push filler ret))) |
| 255 : |
|
|
|
| 256 : |
|
|
;; -------- ;; |
| 257 : |
|
|
;; get-info ;; |
| 258 : |
|
|
;; -------- ;; |
| 259 : |
|
|
(defun get-info (point-or-line key) |
| 260 : |
|
|
(let ((info (assq key (cddr point-or-line)))) |
| 261 : |
|
|
(if info |
| 262 : |
|
|
(cdr info) |
| 263 : |
|
|
nil))) |
| 264 : |
|
|
|
| 265 : |
|
|
;; -------- ;; |
| 266 : |
|
|
;; put-info ;; |
| 267 : |
|
|
;; -------- ;; |
| 268 : |
|
|
(defun put-info (point-or-line key new-info) |
| 269 : |
|
|
(let ((info (assq key (cddr point-or-line)))) |
| 270 : |
|
|
(if info |
| 271 : |
|
|
(setf (cdr info) new-info) |
| 272 : |
|
|
(nconc point-or-line (ncons (cons key new-info))))) |
| 273 : |
|
|
point-or-line) |
| 274 : |
|
|
|
| 275 : |
|
|
;; -------- ;; |
| 276 : |
|
|
;; rem-info ;; |
| 277 : |
|
|
;; -------- ;; |
| 278 : |
|
|
(defun rem-info (point-or-line key) |
| 279 : |
|
|
(setf (cddr point-or-line) |
| 280 : |
|
|
(mapcan (cddr point-or-line) |
| 281 : |
|
|
#'(lambda (x) |
| 282 : |
|
|
(if (eq (first x) key) |
| 283 : |
|
|
nil |
| 284 : |
|
|
(ncons x))))) |
| 285 : |
|
|
point-or-line) |
Annotation of /lisp/tools/skel-lib.l
Parent Directory
| 
Revision Log