home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Menu.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  8.0 KB  |  269 lines
  1. ;;;;
  2. ;;;;  M e n u  . s t k            -- Menu Class definition 
  3. ;;;; 
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;
  15. ;;;; This software is a derivative work of other copyrighted softwares; the
  16. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  17. ;;;;;
  18. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  19. ;;;;    Creation date:  3-Mar-1994 21:03
  20. ;;;; Last file update: 25-Mar-1996 22:57
  21.  
  22. (require "Basics")
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;;;
  26. ;;;; <Menu> class definition
  27. ;;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. (define-class <Menu> (<Tk-simple-widget>)
  31.   (;; The slots hilight* are overloaded here since they don't exist in Tk
  32.    ;; Change the hierarchy?
  33.    (highlight-background :accessor     highlight-background  
  34.              :init-keyword :highlight-background
  35.              :allocation   :virtual
  36.              :slot-ref     (lambda (o) #f)
  37.              :slot-set!    (lambda (o v) v))
  38.    (highlight-color      :accessor     highlight-color  
  39.              :init-keyword :highlight-color
  40.              :tk-name      highlightcolor
  41.              :allocation   :virtual
  42.              :slot-ref     (lambda (o) #f)
  43.              :slot-set!    (lambda (o v) v))
  44.    (highlight-thickness  :accessor     highlight-thickness  
  45.              :init-keyword :highlight-thickness
  46.              :tk-name      highlightthick
  47.              :allocation   :virtual
  48.              :slot-ref     (lambda (o) #f)
  49.              :slot-set!    (lambda (o v) v))
  50.  
  51.    (active-background     :init-keyword :active-background 
  52.              :accessor active-background
  53.              :tk-name activebackground
  54.              :allocation :tk-virtual)
  55.    (active-border-width     :init-keyword :active-border-width 
  56.              :accessor active-border-width
  57.              :tk-name activeborderwidth
  58.              :allocation :tk-virtual)
  59.    (active-foreground     :init-keyword :active-foreground 
  60.              :accessor active-foreground
  61.              :tk-name activeforeground
  62.              :allocation :tk-virtual)
  63.    (disabled-foreground  :init-keyword :disabled-foreground 
  64.              :accessor disabled-foreground
  65.              :tk-name disabledforeground
  66.              :allocation :tk-virtual)
  67.    (font          :init-keyword :font 
  68.              :accessor font 
  69.              :allocation  :tk-virtual)
  70.    (foreground           :init-keyword :foreground 
  71.              :accessor foreground 
  72.              :allocation :tk-virtual)
  73.    (post-command      :init-keyword :post-command 
  74.              :accessor post-command
  75.              :tk-name postcommand
  76.              :allocation :tk-virtual)
  77.    (select-color      :init-keyword :select-color 
  78.              :accessor select-color
  79.              :tk-name selectcolor
  80.              :allocation :tk-virtual)
  81.    (tear-off          :init-keyword :tear-off 
  82.              :accessor tear-off
  83.              :tk-name tearoff
  84.              :allocation :tk-virtual))
  85.   :metaclass <Tk-metaclass>)
  86.  
  87.  
  88. (define-method tk-constructor ((self <Menu>))
  89.   Tk:menu)
  90.  
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92. ;;;;
  93. ;;;; <Menu> methods
  94. ;;;;
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96.  
  97. ;;;
  98. ;;; Activate
  99. ;;;
  100. (define-method activate ((self <Menu>) index)
  101.   ((slot-ref self 'Id) 'activate index))
  102.  
  103. ;;;
  104. ;;; Menu-add
  105. ;;;
  106. (define-method menu-add ((self <Menu>) type . args)
  107.   (apply (slot-ref self 'Id) 'add type args))
  108.  
  109. ;;;
  110. ;;; Delete
  111. ;;;
  112. (define-method delete ((self <Menu>) index1 . index2)
  113.   (apply (slot-ref self 'Id) 'delete index1 index2))
  114.  
  115.  
  116. ;;;
  117. ;;; Disable
  118. ;;;
  119. (define-method disable ((self <Menu>) index)
  120.   ((slot-ref self 'Id) 'entryconfigure index :state "disabled"))
  121.  
  122. ;;;
  123. ;;; Enable
  124. ;;;
  125. (define-method enable ((self <Menu>) index)
  126.   ((slot-ref self 'Id) 'entryconfigure index :state "normal"))
  127.  
  128. ;;;
  129. ;;; Menu-entry-configure
  130. ;;;
  131. (define-method menu-entry-configure ((self <Menu>) index . args)
  132.   (apply (slot-ref self 'Id) 'entryconf index args))
  133.  
  134. ;;;
  135. ;;; Menu-index
  136. ;;;
  137. (define-method menu-index ((self <Menu>) index)
  138.   ((slot-ref self 'Id) 'index index))
  139.  
  140. ;;;
  141. ;;; Invoke
  142. ;;;
  143. (define-method invoke ((self <Menu>) index)
  144.   ((slot-ref self 'Id) 'invoke index))
  145.  
  146. ;;;
  147. ;;; Menu-Post
  148. ;;; 
  149. (define-method menu-post ((self <Menu>) x y)
  150.   ((slot-ref self 'Id) 'post x y))
  151.  
  152. ;;;
  153. ;;; Menu-unpost
  154. ;;; 
  155. (define-method menu-unpost ((self <Menu>))
  156.   ((slot-ref self 'Id) 'unpost))
  157.  
  158. ;;;
  159. ;;; Menu-y-position
  160. ;;;
  161. (define-method menu-y-position ((self <Menu>) index)
  162.   ((slot-ref self 'Id) 'ypos index))
  163.  
  164.  
  165.  
  166. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  167. ;;;;
  168. ;;;; <Menu-button> class definition
  169. ;;;;
  170. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  171.  
  172. (define-class <Menu-button> (<Tk-simple-widget> <Tk-sizeable> <Tk-bitmap> 
  173.                  <Tk-simple-text>)
  174.   ((active-background   :accessor     active-background
  175.             :init-keyword :active-background
  176.                 :allocation   :tk-virtual
  177.             :tk-name      activebackground)
  178.    (active-foreground   :accessor     active-foreground
  179.             :init-keyword :active-foreground
  180.             :allocation   :tk-virtual
  181.             :tk-name      activeforeground)
  182.    (disabled-foreground :accessor     disabled-foreground
  183.             :init-keyword :disabled-foreground
  184.             :allocation   :tk-virtual
  185.             :tk-name      disabledf)
  186.    (indicator-on    :init-keyword :indicator-on
  187.             :accessor     indicator-on
  188.             :allocation   :tk-virtual
  189.             :tk-name      indicatoron)
  190.    (menu        :accessor     menu-of
  191.             :allocation   :tk-virtual)
  192.    (state         :accessor     state
  193.             :init-keyword :state
  194.             :allocation   :tk-virtual)
  195.    (underline         :accessor     underline
  196.             :init-keyword :underline
  197.             :allocation   :tk-virtual)))
  198.  
  199. (define-method tk-constructor ((self <Menu-button>))
  200.   Tk:menubutton)
  201.  
  202. (define-method initialize ((self <Menu>) initargs)
  203.   ;; Do normal initialization
  204.   (next-method)
  205.   ;; If a parent is specified, modify the parent menu-button to point self
  206.   (let ((parent (get-keyword :parent initargs #f)))
  207.     (if (and parent (is-a? parent <Menu-button>))
  208.     (slot-set! parent 'menu (Id self)))))
  209.  
  210. ;;;
  211. ;;; Define new accessors for menu slot to allow (set! (menu m-b) m) where m is an
  212. ;;; instance. 
  213. ;;; Note that not init-keyword exists for menu since a menu must be descendant 
  214. ;;; of its's menu button (this implies it must be created after its menu button).
  215. ;;;
  216. (define-method (setter menu-of) ((self <Menu-button>) (v <Menu>))
  217.   (slot-set! self 'menu (slot-ref v 'Id)))
  218.  
  219. (define-method menu-of ((self <Menu-button>))
  220.   (Id->instance (slot-ref self 'menu)))
  221.  
  222. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  223. ;;;;
  224. ;;;; Make-menubar    -- A simper way to make menus
  225. ;;;;
  226. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  227. (define (make-menubar parent l)
  228.   (define (make-menu parent items)
  229.     (let ((m (make <Menu> :parent parent)))
  230.       (for-each (lambda (item)
  231.           (cond
  232.            ; Separator
  233.            ((equal? (car item) "")
  234.                  (menu-add m 'separator))
  235.            ; Normal Menu
  236.            ((and (= (length item) 2)
  237.              (procedure? (cadr item))
  238.              (menu-add m 'command :label   (car item)
  239.                              :command (cadr item))))
  240.            ; Cascade menu
  241.            ((and (= (length item) 2)
  242.              (list? (cadr item))
  243.              (menu-add m 'cascade :label (car item)
  244.                              :menu (make-menu m (cadr item)))))
  245.            (ELSE
  246.                  (apply menu-add m item))))
  247.         items)
  248.       m))
  249.   (let ((f (make <Frame> :parent parent)))
  250.     ;; Store l in the f object to avoid GC problems
  251.     (set-widget-data! (Id f) 
  252.               `(:menu ,l ,@(get-widget-data (Id f))))  
  253.     (for-each (lambda (x)
  254.         (let* ((title (if (list? (car x)) (caar x) (car x)))
  255.                (rest  (cdr x))
  256.                (mb    (make <Menu-button> :text title :parent f)))
  257.  
  258.           (if (list? (car x))
  259.               ;; User has specified pack options. Use them.
  260.               (apply pack mb (cdar x))
  261.               ;; Pack menubutton on left and create its associated menu
  262.               (pack mb :side "left"))
  263.           (make-menu mb rest)))
  264.         l)
  265.     ;; Return the created frame as result
  266.     f))
  267.  
  268. (provide "Menu")
  269.