Annotation of /skeleton-edit/skel-lib.lAnnotation of /skeleton-edit/skel-lib.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 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) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |