;;;;
;;;; L i s t b o x . s t k 		--  Listbox class definition
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; 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.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 28-Feb-1994 14:38
;;;; Last file update: 15-Apr-1995 15:03

(require "Basics")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Listbox> class
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-class <Listbox> (<Tk-simple-widget> <Tk-selectable>
			 <Tk-text-selectable> <Tk-xyscrollable>)
  ((geometry 		:init-keyword :geometry
		   	:accessor     geometry
			:allocation   :tk-virtual)
   (set-grid		:init-keyword :set-grid
		   	:accessor     set-grid
			:tk-name      setgrid
			:allocation   :tk-virtual)
   ;; Fictive slot 
   (value		:accessor     value
			:init-keyword :value
			:allocation   :virtual
			:slot-ref     (lambda (o)
					(let* ((w    (Id o))
					       (nb   (w 'size))
					       (res '()))
					  (do ((i 0 (+ i 1)))
					      ((= i nb) (reverse res))
					    (set! res (cons (w 'get i) res)))))
			:slot-set!    (lambda (o v)
					(let ((w  (Id o)))
					  (w 'delete 0 'end)
					  (apply w 'insert 0 v))))))

(define-method tk-constructor ((self <Listbox>))
  Tk:listbox)

;;;
;;; Current-selection
;;;
(define-method current-selection ((self <Listbox>))
  (let ((res ((slot-ref self 'Id) 'curselection)))
    (if (null? res) #f res)))

;;;
;;; Delete
;;; 
(define-method delete ((self <Listbox>) start . end)
  (apply (slot-ref self 'Id) 'delete start end))

;;;
;;; Get
;;;
(define-method get ((self <Listbox>) index)
  ((slot-ref self 'Id) 'get index))

;;;
;;; Insert
;;;
(define-method insert ((self <Listbox>) index . value)
  (apply (slot-ref self 'Id) 'insert index value))

;;;
;;; Nearest
;;; 
(define-method nearest ((self <Listbox>) index)
  ((slot-ref self 'Id) 'nearest index))


;;;
;;; Mark 
;;; 
(define-method text-mark ((self <Listbox>) x y)
  ((slot-ref self 'Id) 'scan 'mark x y))

;;;
;;; Drag-to 
;;; 
(define-method text-drag-to ((self <Listbox>) x y)
  ((slot-ref self 'Id) 'scan 'dragto x y))

;;;
;;; Select
;;; 
(define-method select ((self <Listbox>) option . index)
  (if (equal? option :clear)
      (begin
	(unless (null? index) 
	  (error "**** You can't specify an index in a select/clear"))
	((slot-ref self 'Id) 'select 'clear))
      (apply (slot-ref self 'Id) 'select (format #f "~A" option) index)))


;;;
;;; Size
;;; 
(define-method size ((self <Listbox>))
  ((slot-ref self 'Id) 'size))

;;;
;;; X-View
;;; 
(define-method x-view ((self <Listbox>) index)
  ((slot-ref self 'Id) 'xview index))

;;;
;;; Y-View
;;; 
(define-method y-view ((self <Listbox>) index)
  ((slot-ref self 'Id) 'yview index))


(provide "Listbox")