GLB 1.1

From: Walter C. Pelissero <wcp_at_luppolo.lpds.sublink.org>
Date: Thu, 14 May 1998 20:26:40 +0200 (CEST)

As suggested by Erik Gallesio, below I'm including an implementation
of a little composite widget that let you choose items from one
listbox (the source-value), put them in another one (the value) and
back to the former. It's something rather common in M$-Windows.

The main bug, I belive, is the name. Since I never saw MFC I didn't
have inspirations for a good name. If you think of a better name, let
me know.

Enjoy it.

--------------------8<--------------------8<--------------------
;;; glb.stk --- grab list box

;;; _at_(#)$Id: glb.stk,v 1.1 1998/05/07 08:23:21 wcp Exp $

;;; Copyright (C) 1998 by Walter C. Pelissero

;;; Author: Walter C. Pelissero <wcp_at_lpds.sublink.org>

;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted,
;;;; provided that both the above copyright notice and this permission
;;;; notice appear in all copies and derived works. Fees for
;;;; distribution or use of this software or derived works may only be
;;;; charged with express written permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied
;;;; warranty.

;;; Code:

(require "Basics")
(require "Tk-classes")
(select-module STklos+Tk)

(define-class <Grab-listbox> (<Tk-composite-widget> <Listbox>)
  ((source-listbox :accessor source-listbox)
   (target-listbox :accessor target-listbox)
   (buttons-frame)
   (add-button)
   (del-button)
   ;; Fictive slots
   (source-value :accessor source-value
                 :init-keyword :source-value
                 :allocation :virtual
                 :slot-ref (lambda (o)
                             (value (slot-ref o 'source-listbox)))
                 :slot-set! (lambda (o v)
                              (set! (value (slot-ref o 'source-listbox)) v)))
   ;; Non allocated slots
   (state :accessor state
                 :init-keyword :state
                 :allocation :propagated
                 :propagate-to (add-button del-button))
   (select-mode :accessor select-mode
                 :init-keyword :select-mode
                 :allocation :propagated
                 :propagate-to (source-listbox target-listbox))
   (background :accessor background
                 :init-keyword :background
                 :allocation :propagated
                 :propagate-to (frame buttons-frame source-listbox
                                      target-listbox add-button del-button))
   (border-width :accessor border-width
                 :allocation :propagated
                 :init-keyword :border-width
                 :propagate-to (frame))
   (relief :accessor relief
                 :init-keyword :relief
                 :allocation :propagated
                 :propagate-to (frame))))

(define-method initialize-composite-widget ((self <Grab-listbox>) initargs parent)
  (let* ((src (make <Scroll-listbox> :parent parent :select-mode 'multiple))
         (trg (make <Scroll-listbox> :parent parent :select-mode 'multiple))
         (f (make <Frame> :parent parent))
         (move (lambda (src trg)
                 (lambda ()
                   (let ((sel (current-selection src)))
                     (if sel
                         (begin
                           (for-each (lambda (x)
                                       (insert trg 'end (get src x)))
                                     sel)
                           (for-each (lambda (x)
                                       (delete src x))
                                     (sort sel >))))))))
         (ab (make <Button> :parent f :text "Add-->"
                   :command (move src trg)))
         (db (make <Button> :parent f :text "<--Remove"
                   :command (move trg src))))

    ;; Set internal true slots
    (slot-set! self 'Id (slot-ref trg 'Id))
    (slot-set! self 'source-listbox src)
    (slot-set! self 'target-listbox trg)
    (slot-set! self 'buttons-frame f)
    (slot-set! self 'add-button ab)
    (slot-set! self 'del-button db)

    ;; Place internal widgets
    (pack src :side 'left)
    (pack ab :fill 'x :expand #t)
    (pack db :fill 'x :expand #t)
    (pack f :side 'left)
    (pack trg :side 'left)))

(provide "glb")


#|
        Usage:
        (define gb (make <Grab-listbox> :source-value '(a b c d e f)
                         :value '(g h i)))
        (pack gb)
|#

;;; glb.stk ends here
Received on Fri May 15 1998 - 03:33:18 CEST