[plt-scheme] MrEd tab-panel%

Hi all,

I try to add a feature to MrEd Designer where it can handle
tab-panels
correctly. However I have a problem.

In MrEd Designer I create all sorts of widgets. In all widgets
the on-subwindow event is overwritten with a special code.
I do this with the tab-panel as well. However the tab-panel
widget
is unique, as it contains internal widgets which are not exposed
to the world. The tab-panel% class contains a tab-group%.
Now when I click on the panel the tab-panel% receives the
event, but
when I click on a tab (at the top of the panel) the tab-group% 
receives, which event I cannot handle.
So I try to create a new tab-panel% class like in
frtime/gui/mod-mrpanel.ss
In this case the tab-panel% is a vertical-panel%, which contains
a tab-group%, however I also create a panel:single% object
inside which will do the switching. But I cannot add the
panel:single%
to tab-group% as tab-group% is not an internal container.

So my question is:
How can I make a tab-group% object which is also an internal
container???

I include a working code below and I have marked the line
where I cannot add panel:single% to tab-group%.
At least I think that is the problem.

Can someone help me with this? (Matthew, Robby ???)

Thanks for any help,

Peter Ivanyi

----------------------------------------------------------------------------------


(module tab-test mzscheme
  (require mzlib/class
	   (prefix wx: (lib "kernel.ss" "mred" "private"))
	   (lib "lock.ss" "mred" "private")
	   (lib "const.ss" "mred" "private")
	   (lib "check.ss" "mred" "private")
	   (lib "helper.ss" "mred" "private")
	   (lib "wx.ss" "mred" "private")
	   (lib "kw.ss" "mred" "private")
	   (lib "mrwindow.ss" "mred" "private")
	   (lib "mrcontainer.ss" "mred" "private")
	   (lib "mrtabgroup.ss" "mred" "private")
	   (lib "mrgroupbox.ss" "mred" "private")
           (lib "mred.ss" "mred")
           (lib "framework.ss" "framework") ; for tab panels
  )

  
  (define mred-frame%
    (class frame%
      ; id of the frame in the data list
      (init-field 
        (mred-id #f)
        (preview-callback #f)
      )
      (define/public (mred-id-set! id)
        (set! mred-id id))
      (define/public (mred-id-get)
        mred-id)
      
      (define/override (on-subwindow-event w e)
        (let
          ((type (send e get-event-type)))
          (if (equal? type 'left-down)
            (let
              ((id (send w mred-id-get)))
              (if (and preview-callback (procedure?
preview-callback))
                (preview-callback id)
              )
            )
          )
          #f
        )
      )
  
      (super-new)
    )
  )
  
  
  (define mred-tab-group%
    (class tab-group%
      (init-field 
        (mred-id #f)
        (preview-callback #f)
      )
      (define/public (mred-id-set! id)
        (set! mred-id id))
      (define/public (mred-id-get)
        mred-id)
        
      (super-new)
    )
  )

  ; special class for tab-panel
  (define mred-tab-panel%
    (class vertical-panel%
      (init-field 
        (mred-id #f)
        (preview-callback #f)
        (choices '())
      )
      (define/public (mred-id-set! id)
        (set! mred-id id))
      (define/public (mred-id-get)
        mred-id)
            
      (super-new)

      (define panel-list '())
      (define panel-name '())
      (define tabs
        (new mred-tab-group% 
             (label "") 
             (choices choices)
             (parent this)
             (style '(border))
             (callback 
               (lambda (w e)
                 (send (send this get-single)
                       active-child
                       (list-ref panel-list (send this
get-selection)))
               )))
      )

      ;;;;;; PROBLEM ;;;;;;;;;;
      ;;;;;; 'this' should be tabs !!!!
      (define panel-single (new panel:single% (parent this)))
      
      (define/public (get-selection)
        (send (mred->wx tabs) get-selection)
      )
      (define/public (get-tabs)
        tabs
      )
      (define/public (get-single)
        panel-single
      )
      (define/public (tab-add widget label)
        (send (mred->wx tabs) append label)
        (set! panel-list (append panel-list (list widget)))
        (set! panel-name (append panel-name (list label)))
      )
    )
  )
  
  (define mred-tab%
    (class vertical-panel%
      (init-field 
        (mred-id #f)
        (preview-callback #f)
        (label "")
      )
      (define/public (mred-id-set! id)
        (set! mred-id id))
      (define/public (mred-id-get)
        mred-id)
      
      (define/override (set-label text)
        (set! label text)
      )
      
      (super-new)
      
      ; add this tab to parent as well
      (send (send (send this get-parent) get-parent) tab-add
this label)
    )
  )
  
  (define w (new mred-frame% (label "Hello")
                 (min-width 200)
                 (min-height 200)
                 ))
  
  
  (define panel-name '())
  (define tab-panel (new mred-tab-panel% (parent w) (choices
panel-name)))

  
  (define vert1 (new mred-tab% (parent (send tab-panel
get-single)) (label "aa"))) 
  (define b1 (new button% (label "11111") (parent vert1)))
  
  (define vert2 (new mred-tab% (parent (send tab-panel
get-single)) (label "bb"))) 
  (define b2 (new button% (label "22222") (parent vert2)))
  
  (send w show #t)
  
)


______________________________________________________________________
Egész nyáron szombat esti láz!
http://videa.hu/videok/zene/mtv-icon-tribute-to-lgt-balaton-cokeclub-coketv-YUxNbEgI5kzWjLjP