View of /skeleton-edit/menu.l

Parent Directory

Revision Log

*** empty log message ***

(defun move-win (win x y)
  (setf (drawable-x win) x)
  (setf (drawable-y win) y))

(defun create-menu-test (parent x y black white fnt cursor
				item-list (colnum 1))
  (lets ((mw     (create-win parent x y 10 10 black white fnt))
	 (wins   (mapcar item-list
			 #'(lambda (x) 
			     (create-menu-item-win mw    (second x) 
						   0     0
						   black white
						   fnt   cursor))))
	 (item-num (length item-list))
	 (item-height (apply #'max
			     (mapcar wins #'drawable-height)))
	 (item-width  (apply #'max
			     (mapcar wins #'drawable-width)))
	 (linnum   (// (1- (+ item-num colnum)) colnum))
	 (mw-height (+ (* linnum item-height) *menu-margin*))
	 (mw-width  (* colnum (+ *menu-margin* item-width))))
    (do ((item-wins wins)
	 (y 0 (+ y item-height)))
	((endp item-wins))
	(do ((x 0 (+ x (+ item-width *menu-margin*)))
	     (c 0 (1+ c)))
	    ((or (>= c colnum) (endp item-wins)))
	    (move-win (car item-wins) x y)
	    (setq item-wins (cdr item-wins))))
    
    (do ((items item-list (cdr items))
	 (windefs wins (cdr windefs)))
	((or (endp items) (endp windefs)))
	(princ (caar items)) (princ " ")
	(set (caar items) (car windefs)))
    (terpri)

    (mapcar wins #'(lambda (x) (resize-win x item-width item-height)))
    (resize-win mw mw-width mw-height)
    mw))

(defun test ()
  (setq test-win (create-menu-test	
		  skeleditor 0 0 black white kanji-font roupe-cursor
		  '((test-1 "テト１")
		    (test-2 "テスト２")
		    (test-3 "テスト３")
		    (test-4 "テスト４")
		    (test-5 "テスト５"))))
  (map-subwindows test-win)
  (map-window test-win)
  (display-force-output (window-display test-win)))