| 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 : |
|
|
|
Annotation of /lisp/tools/menu.l
Parent Directory
| 
Revision Log