stk/STklos/Tk/Scale.stklos

140 lines
4.1 KiB
Plaintext
Raw Normal View History

1996-09-27 06:29:02 -04:00
;;;;
;;;; S c a l e . s t k -- Scale Class definition
;;;;
;;;;
1999-09-05 07:16:41 -04:00
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1996-09-27 06:29:02 -04:00
;;;;
1999-09-05 07:16:41 -04:00
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
1998-04-10 06:59:06 -04:00
;;;;
1996-09-27 06:29:02 -04:00
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: 30-Mar-1993 15:28
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 20:11 (eg)
1996-09-27 06:29:02 -04:00
(require "Basics")
1998-04-10 06:59:06 -04:00
(select-module STklos+Tk)
(export coords get identify)
1996-09-27 06:29:02 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Scale> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Scale> (<Tk-simple-widget>)
((active-background :init-keyword :active-background
:accessor active-background
:tk-name activebackground
:allocation :tk-virtual)
(big-increment :init-keyword :big-increment
:accessor big-increment
:allocation :tk-virtual
:tk-name bigincrement)
(command :init-keyword :command
:accessor command
:allocation :tk-virtual)
(digits :init-keyword :digits
:accessor digits
:allocation :tk-virtual)
(font :init-keyword :font
:accessor font
:allocation :tk-virtual)
(foreground :init-keyword :foreground
:accessor foreground
:allocation :tk-virtual)
(from :init-keyword :from
:accessor from
:allocation :tk-virtual)
(scale-length :init-keyword :scale-length
:accessor scale-length
:tk-name length
:allocation :tk-virtual)
(orientation :init-keyword :orientation
:accessor orientation
:tk-name orient
:allocation :tk-virtual)
(repeat-delay :init-keyword :repeat-delay
:accessor repeat-delay
:tk-name repeatdelay
:allocation :tk-virtual)
(repeat-interval :init-keyword :repeat-interval
:accessor repeat-interval
:tk-name repeatinterval
:allocation :tk-virtual)
(resolution :init-keyword :resolution
:accessor resolution
:allocation :tk-virtual)
(show-value :init-keyword :show-value
:accessor show-value
:tk-name showvalue
:allocation :tk-virtual)
(slider-length :init-keyword :slider-length
:accessor slider-length
:tk-name sliderlength
:allocation :tk-virtual)
(state :init-keyword :state
:accessor state
:allocation :tk-virtual)
(text :init-keyword :text
:accessor text-of
:tk-name label
:allocation :tk-virtual)
(tick-interval :init-keyword :tick-interval
:accessor tick-interval
:tk-name tickinterval
:allocation :tk-virtual)
(to :init-keyword :to
:accessor to
:allocation :tk-virtual)
(trough-color :init-keyword :trough-color
:accessor trough-color
:tk-name troughcolor
:allocation :tk-virtual)
(variable :init-keyword :variable
:accessor variable
:allocation :tk-virtual)
(width :init-keyword :width
:accessor 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)
((slot-ref o 'Id) 'set v)))))
(define-method tk-constructor ((self <Scale>))
Tk:scale)
1998-04-30 07:04:33 -04:00
1996-09-27 06:29:02 -04:00
;;;
;;; <Scale> methods
;;;
(define-method initialize ((self <Scale>) initargs)
(next-method)
1998-04-30 07:04:33 -04:00
(let ((val (get-keyword :value initargs #f)))
1996-09-27 06:29:02 -04:00
;; If a value is specified upon init, set it.
(when val
1998-04-30 07:04:33 -04:00
(initialize-value-slot self val))))
1996-09-27 06:29:02 -04:00
(define-method coords ((self <Scale>) . value)
(apply (slot-ref self 'Id) 'coords value))
(define-method get ((self <Scale>) x y)
1998-04-10 06:59:06 -04:00
((slot-ref self 'Id) 'get x y))
1996-09-27 06:29:02 -04:00
(define-method identify ((self <Scale>) x y)
((slot-ref self 'Id) 'identify x y))
1998-04-10 06:59:06 -04:00
(provide "Scale")