Annotation of /skeleton-edit/menu.lAnnotation of /skeleton-edit/menu.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | |
| 2 : | (defun move-win (win x y) | ||
| 3 : | (setf (drawable-x win) x) | ||
| 4 : | (setf (drawable-y win) y)) | ||
| 5 : | |||
| 6 : | (defun create-menu-test (parent x y black white fnt cursor | ||
| 7 : | item-list (colnum 1)) | ||
| 8 : | (lets ((mw (create-win parent x y 10 10 black white fnt)) | ||
| 9 : | (wins (mapcar item-list | ||
| 10 : | #'(lambda (x) | ||
| 11 : | (create-menu-item-win mw (second x) | ||
| 12 : | 0 0 | ||
| 13 : | black white | ||
| 14 : | fnt cursor)))) | ||
| 15 : | (item-num (length item-list)) | ||
| 16 : | (item-height (apply #'max | ||
| 17 : | (mapcar wins #'drawable-height))) | ||
| 18 : | (item-width (apply #'max | ||
| 19 : | (mapcar wins #'drawable-width))) | ||
| 20 : | (linnum (// (1- (+ item-num colnum)) colnum)) | ||
| 21 : | (mw-height (+ (* linnum item-height) *menu-margin*)) | ||
| 22 : | (mw-width (* colnum (+ *menu-margin* item-width)))) | ||
| 23 : | (do ((item-wins wins) | ||
| 24 : | (y 0 (+ y item-height))) | ||
| 25 : | ((endp item-wins)) | ||
| 26 : | (do ((x 0 (+ x (+ item-width *menu-margin*))) | ||
| 27 : | (c 0 (1+ c))) | ||
| 28 : | ((or (>= c colnum) (endp item-wins))) | ||
| 29 : | (move-win (car item-wins) x y) | ||
| 30 : | (setq item-wins (cdr item-wins)))) | ||
| 31 : | |||
| 32 : | (do ((items item-list (cdr items)) | ||
| 33 : | (windefs wins (cdr windefs))) | ||
| 34 : | ((or (endp items) (endp windefs))) | ||
| 35 : | (princ (caar items)) (princ " ") | ||
| 36 : | (set (caar items) (car windefs))) | ||
| 37 : | (terpri) | ||
| 38 : | |||
| 39 : | (mapcar wins #'(lambda (x) (resize-win x item-width item-height))) | ||
| 40 : | (resize-win mw mw-width mw-height) | ||
| 41 : | mw)) | ||
| 42 : | |||
| 43 : | (defun test () | ||
| 44 : | (setq test-win (create-menu-test | ||
| 45 : | skeleditor 0 0 black white kanji-font roupe-cursor | ||
| 46 : | '((test-1 "テト１") | ||
| 47 : | (test-2 "テスト２") | ||
| 48 : | (test-3 "テスト３") | ||
| 49 : | (test-4 "テスト４") | ||
| 50 : | (test-5 "テスト５")))) | ||
| 51 : | (map-subwindows test-win) | ||
| 52 : | (map-window test-win) | ||
| 53 : | (display-force-output (window-display test-win))) | ||
| 54 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |