;;;;
;;;; E n t r y . s t k 		--  Entry class definition
;;;;
;;;; Copyright © 1993-1998 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.
;;;;
;;;; $Id: Entry.stklos 1.6 Mon, 27 Apr 1998 13:39:00 +0000 eg $
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 28-Feb-1994 11:36
;;;; Last file update: 27-Apr-1998 12:09

(require "Basics")

(select-module STklos+Tk)

(export bounding-box text-delete text-cursor (setter text-cursor)
	text-index text-insert text-mark text-drag-to selection-adjust
	selection-set! selection-to! text-x-view)

;=============================================================================
;
;				 <Entry> class
;
;=============================================================================

(define-class <Entry> (<Tk-simple-widget> <Tk-editable> <Tk-selectable> 
		       <Tk-text-selectable>)
  ((environment	     :accessor	   environment
		     :init-keyword :environment
		     :allocation   :tk-virtual)
   (justify	     :accessor	   justify
		     :init-keyword :justify
		     :allocation   :tk-virtual)
   (x-scroll-command :init-keyword :x-scroll-command
		     :accessor	   x-scroll-command
		     :tk-name	   xscrollcommand
		     :allocation   :tk-virtual)
   (text-variable    :accessor	   text-variable
		     :init-keyword :text-variable
		     :allocation   :tk-virtual
		     :tk-name	   textvar)
   (show-chars	     :accessor	   show-chars
		     :init-keyword :show-chars
		     :allocation   :tk-virtual
		     :tk-name	   show)
   (state	     :accessor	   state
		     :init-keyword :state
		     :allocation   :tk-virtual)
   (string-value     :accessor	   string-value
		     :init-keyword :string-value
		     :tk-name      stringval
		     :allocation   :tk-virtual)
   (width	     :accessor     width
		     :init-keyword :width 
		     :allocation   :tk-virtual)
   ;; Fictive slot 
   (value     	     :accessor	   value
	      	     :init-keyword :value
	      	     :allocation   :virtual
	             :slot-ref     (lambda (o)  
				     ((slot-ref o 'Id) 'get))
	             :slot-set!    (lambda (o v) 
				     ;; First delete all present chars
				     ((slot-ref o 'Id) 'delete 0 'end)
				     ;; Then insert new text
				     ((slot-ref o 'Id) 'insert 0 v)))))

(define-method tk-constructor ((self <Entry>))
  Tk:entry)


(define-method initialize ((self <Entry>) initargs)
  (next-method)
   ;; If a value is specified upon init, set it.
  (let ((val (get-keyword :value initargs #f)))
    (when val (initialize-value-slot self val))))

;;;
;;; bounding-box
;;;
(define-method bounding-box ((self <Entry>) index)
  ((slot-ref self 'Id) 'bbox index))

;;;
;;; Delete
;;; 
(define-method text-delete ((self <Entry>) start)
  ((slot-ref self 'Id) 'delete start))

(define-method text-delete ((self <Entry>) start end)
  ((slot-ref self 'Id) 'delete start end))


;;;
;;; Cursor and (setter Cursor)
;;;
(define-method text-cursor ((self <Entry>))
  ((slot-ref self 'Id) 'index 'insert))

(define-method (setter text-cursor) ((self <Entry>) index)
  ((slot-ref self 'Id) 'icursor index))

;;;
;;; Index 
;;;
(define-method text-index ((self <Entry>) index)
  ((slot-ref self 'Id) 'index index))

;;;
;;; Insert
;;;
(define-method text-insert ((self <Entry>) text)
  ((slot-ref self 'Id) 'insert 'insert text))

(define-method text-insert ((self <Entry>) text position)
  (let ((entry (slot-ref self 'Id)))
    (entry 'icursor (car position))
    (entry 'insert 'insert text)))

;;;
;;; Mark 
;;; 
(define-method text-mark ((self <Entry>) pos)
  ((slot-ref self 'Id) 'scan 'mark pos))

;;;
;;; Drag-to 
;;; 
(define-method text-drag-to ((self <Entry>) pos)
  ((slot-ref self 'Id) 'scan 'dragto pos))

;;;
;;; Selection-anchor
;;; 
(define-method selection-adjust ((self <Entry>) index)
  ((slot-ref self 'Id) 'selection 'adjust index))

;;;
;;; Selection-clear
;;; 
(define-method selection-clear ((self <Entry>))
  (apply (slot-ref self 'Id) 'selection 'clear))

;;;
;;; Selection-present?
;;; 
(define-method selection-present? ((self <Entry>))
  ((slot-ref self 'Id) 'selection 'present))

;;;
;;; Selection-set!
;;; 
(define-method selection-set! ((self <Entry>) first  last)
  (let ((Id (slot-ref self 'Id)))
    (Id 'selection 'clear)
    (Id 'selection 'from first)
    (Id 'selection 'to last)))

;;;
;;; Selection-to!
;;; 
(define-method selection-to! ((self <Entry>) index)
  ((slot-ref self 'Id) 'selection 'set index))

;;;
;;; X-view
;;; 
(define-method text-x-view ((self <Entry>) . args)
  (apply (slot-ref self 'Id) 'xview args))

(provide "Entry")