173 lines
6.6 KiB
TeX
173 lines
6.6 KiB
TeX
\begin{alltt}
|
|
{\it ;;;;}
|
|
{\it ;;;; {\bf Utilities}}
|
|
{\it ;;;;}
|
|
(define make-tk-name
|
|
(lambda (parent)
|
|
(gensym (format #f "~A.v" (if (eq? parent *root*) "" (Id parent))))))
|
|
|
|
(define split-options
|
|
(lambda (valid-slots initargs)
|
|
(letrec
|
|
((separate
|
|
(lambda (valids args tk-opt other)
|
|
(if (null? args)
|
|
(cons tk-opt other)
|
|
(if (member (car args) valids)
|
|
(separate valids (cddr args)
|
|
(list* (car args) (cadr args) tk-opt)
|
|
other)
|
|
(separate valids (cddr args)
|
|
tk-opt
|
|
(list* (car args) (cadr args) other)))))))
|
|
(separate valid-slots initargs '() '()))))
|
|
|
|
{\it ;;;;}
|
|
{\it ;;;; {\bf Simple widgets}}
|
|
{\it ;;;;}
|
|
{\it ;; }
|
|
{\it ;; {\tt{}<}Tk-metaclass{\tt{}>} class definition and associated methods}
|
|
{\it ;;}
|
|
(define-class {\tt{}<}Tk-Metaclass{\tt{}>} ({\tt{}<}class{\tt{}>})
|
|
((valid-options :accessor Tk-valid-options)))
|
|
|
|
|
|
(define-method initialize ((class {\tt{}<}Tk-Metaclass{\tt{}>}) initargs)
|
|
(next-method)
|
|
{\it ;; Build a list of allowed keywords. These keywords will be passed to}
|
|
{\it ;; the Tk-command at build time}
|
|
(let ((slots (slot-ref class 'slots))
|
|
(res '())
|
|
(tk-virtual? (lambda(s)
|
|
(eqv? (get-slot-allocation s) :tk-virtual))))
|
|
(for-each (lambda (s)
|
|
(when (tk-virtual? s)
|
|
(let ((key (make-keyword (car s))))
|
|
(set! res (cons key res)))))
|
|
slots)
|
|
{\it ;; Store this list in the new allocated class}
|
|
(set! (Tk-valid-options class) res)))
|
|
|
|
|
|
(define-method compute-get-n-set ((class {\tt{}<}Tk-Metaclass{\tt{}>}) slot)
|
|
(if (eqv? (get-slot-allocation slot) :tk-virtual)
|
|
{\it ;; this is a Tk-virtual slot}
|
|
(let ((opt (make-keyword (car slot))))
|
|
(list (lambda (o) (list-ref ((Id o) 'configure opt) 4))
|
|
(lambda (o v) ((Id o) 'configure opt v))))
|
|
{\it ;; call super compute-get-n-set}
|
|
(next-method)))
|
|
|
|
{\it ;;}
|
|
{\it ;; Basic virtual classes for widgets: {\tt{}<}Tk-object{\tt{}>}, {\tt{}<}Tk-widget{\tt{}>} and }
|
|
{\it ;; {\tt{}<}Tk-simple-widget{\tt{}>}}
|
|
{\it ;;}
|
|
(define-class {\tt{}<}Tk-object{\tt{}>} ()
|
|
((Id :accessor Id) {\it ;; Widget Id}
|
|
(parent :accessor parent :init-keyword :parent))) {\it ;; Parent widget}
|
|
|
|
(define-class {\tt{}<}Tk-widget{\tt{}>} ({\tt{}<}Tk-object{\tt{}>})
|
|
())
|
|
|
|
|
|
|
|
(define-class {\tt{}<}Tk-simple-widget{\tt{}>} ({\tt{}<}Tk-widget{\tt{}>})
|
|
{\it ;; Each widget has at least the slot bg for its background colour}
|
|
((bg :accessor bg :init-keyword :bg :allocation :tk-virtual))
|
|
:metaclass {\tt{}<}Tk-Metaclass{\tt{}>})
|
|
|
|
|
|
(define-method initialize ((self {\tt{}<}Tk-simple-widget{\tt{}>}) initargs)
|
|
{\it ;; Use split-options on initargs to separate STklos slots }
|
|
{\it ;; from Tk ones. Set parent to the root window if not specified}
|
|
{\it ;; in initargs}
|
|
(let* ((options (split-options (Tk-valid-options (class-of self))
|
|
initargs))
|
|
(parent (get-keyword :parent (cdr options) *root*)))
|
|
{\it ;; Call the Tk command which creates the widget}
|
|
(set! (Id self) (apply (tk-constructor self)
|
|
(make-tk-name parent)
|
|
(car options)))
|
|
{\it ;; Initialize other slots (i.e. non Tk-virtual ones)}
|
|
(next-method self (cdr options))))
|
|
|
|
|
|
{\it ;;}
|
|
{\it ;; We can now define three widget classes: {\tt{}<}Label{\tt{}>}, {\tt{}<}Button{\tt{}>} and {\tt{}<}Canvas{\tt{}>}}
|
|
{\it ;; as well as their associated Tk-command}
|
|
{\it ;;}
|
|
(define-class {\tt{}<}Label{\tt{}>} ({\tt{}<}Tk-simple-widget{\tt{}>})
|
|
((font :accessor font :init-keyword :font :allocation :tk-virtual)
|
|
(text :accessor text :init-keyword :text :allocation :tk-virtual)))
|
|
|
|
(define-class {\tt{}<}Button{\tt{}>} ({\tt{}<}Label{\tt{}>})
|
|
((command :accessor command :init-keyword :command
|
|
:allocation :tk-virtual)))
|
|
|
|
(define-class {\tt{}<}Canvas{\tt{}>} ({\tt{}<}Tk-simple-widget{\tt{}>})
|
|
())
|
|
|
|
(define-method tk-constructor ((self {\tt{}<}Label{\tt{}>})) label)
|
|
(define-method tk-constructor ((self {\tt{}<}Button{\tt{}>})) button)
|
|
(define-method tk-constructor ((self {\tt{}<}Canvas{\tt{}>})) canvas)
|
|
|
|
|
|
{\it ;;;;}
|
|
{\it ;;;; {\bf Canvas items widgets}}
|
|
{\it ;;;;}
|
|
{\it ;; }
|
|
{\it ;; {\tt{}<}Tk-item-metaclass{\tt{}>} class definition and associated methods }
|
|
{\it ;; }
|
|
|
|
(define-class {\tt{}<}Tk-item-metaclass{\tt{}>} ({\tt{}<}Tk-Metaclass{\tt{}>})
|
|
())
|
|
|
|
(define-method compute-get-n-set ((class {\tt{}<}Tk-item-metaclass{\tt{}>}) slot)
|
|
(if (eqv? (get-slot-allocation slot) :tk-virtual)
|
|
{\it ;; this is a Tk-virtual slot}
|
|
(let ((opt (make-keyword (car slot))))
|
|
(list (lambda (obj)
|
|
(list-ref ((Id obj) 'itemconfigure (Cid obj) opt) 4))
|
|
(lambda (obj val)
|
|
((Id obj) 'itemconfigure (Cid obj) opt val))))
|
|
{\it ;; call super compute-get-n-set}
|
|
(next-method)))
|
|
|
|
{\it ;;}
|
|
{\it ;; Basic virtual class: {\tt{}<}Tk-canvas-item{\tt{}>} }
|
|
{\it ;;}
|
|
(define-class {\tt{}<}Tk-canvas-item{\tt{}>} ({\tt{}<}Tk-object{\tt{}>})
|
|
((Cid :accessor Cid)
|
|
(width :accessor width :allocation :tk-virtual))
|
|
:metaclass {\tt{}<}Tk-item-metaclass{\tt{}>})
|
|
|
|
|
|
(define-method initialize ((self {\tt{}<}Tk-canvas-item{\tt{}>}) initargs)
|
|
(let* ((options (split-options (Tk-valid-options (class-of self))
|
|
initargs))
|
|
(parent (get-keyword :parent (cdr options) #f))
|
|
(coords (get-keyword :coords (cdr options) #f)))
|
|
(if (not (and parent coords))
|
|
(error "Parent widget and coordinates must be given!!"))
|
|
(set! (Id self) (Id parent))
|
|
(set! (CId self) (apply (Id parent)
|
|
'create
|
|
(canvas-item-initializer self)
|
|
(append coords (car options))))
|
|
{\it ;; Initialize other slots (i.e. non Tk-virtual ones)}
|
|
(next-method self (cdr options))))
|
|
|
|
{\it ;;}
|
|
{\it ;; We can now define two canvas item classes: {\tt{}<}Line{\tt{}>} and {\tt{}<}Rectangle{\tt{}>}}
|
|
{\it ;; as well as their associated initializer}
|
|
{\it ;;}
|
|
(define-class {\tt{}<}Line{\tt{}>} ({\tt{}<}Tk-canvas-item{\tt{}>})
|
|
())
|
|
|
|
(define-class {\tt{}<}Rectangle{\tt{}>} ({\tt{}<}Tk-canvas-item{\tt{}>})
|
|
((fill :accessor fill :init-keyword :fill :allocation :tk-virtual)))
|
|
|
|
(define-method canvas-item-initializer ((self {\tt{}<}Rectangle{\tt{}>})) "rectangle")
|
|
(define-method canvas-item-initializer ((self {\tt{}<}Line{\tt{}>})) "line")
|
|
\end{alltt}
|