Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 120 lines (92 sloc) 4.94 KB
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
Celtk -- Cells, Tcl, and Tk
Copyright (C) 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(, known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
See the Lisp Lesser GNU Public License for more details.
(in-package :Celtk)
;;; --- tk-object ------------------
(defmodel tk-object (model)
((.md-name :cell nil :initform (gentemp "TK") :initarg :id)
(tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)
(timers :owning t :initarg :timers :accessor timers :initform nil)
(on-command :initarg :on-command :accessor on-command :initform nil)
(on-key-down :initarg :on-key-down :accessor on-key-down :initform nil
:documentation "Long story. Tcl C API weak for keypress events. This gets dispatched
eventually thanks to DEFCOMMAND")
(on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
(user-errors :initarg :user-errors :accessor user-errors :initform nil)
(tile? :initform t :cell nil :reader tile? :initarg :tile?))
(:documentation "Root class for widgets and (canvas) items"))
(export! valid? ^valid?)
(defun valid? (self)
(not (^user-errors)))
(defmacro ^valid? ()
'(valid? self))
(defmethod md-awaken :before ((self tk-object))
(make-tk-instance self))
(defmethod parent-path ((self tk-object)) (path self))
;;; --- deftk --------------------
(defmacro deftk (class superclasses (&rest std-slots) &rest defclass-options)
(destructuring-bind (&optional tk-class &rest tk-options)
(cdr (find :tk-spec defclass-options :key 'car))
(setf tk-options (tk-options-normalize tk-options))
(defmodel ,class ,(or superclasses '(tk-object))
(,@(append std-slots (loop for (slot-name nil) in tk-options
collecting `(,slot-name :initform nil
:initarg ,(intern (string slot-name) :keyword)
:accessor ,slot-name))))
,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car)
,@(when tk-class `(:tk-class ',tk-class))
,@(cdr (find :default-initargs defclass-options :key 'car))))
(defmethod tk-class-options append ((self ,class))
(export ',(loop for (slot nil) in tk-options
nconcing (list slot (intern (conc$ "^" slot)))))
(defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits)
`(make-instance ',',class
:fm-parent *parent*
(defun tk-options-normalize (tk-options)
"normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))"
(loop for tk-option-def in tk-options
for slot-name = (intern (de- (if (atom tk-option-def)
tk-option-def (car tk-option-def))))
collecting (list slot-name (if (atom tk-option-def)
tk-option-def (cadr tk-option-def)))))
(defun de- (sym)
(remove #\- (symbol-name sym) :end 1)))
(defgeneric tk-class-options (self)
(:method-combination append)
(:method :around (self)
(or (get (type-of self) 'tk-class-options)
(setf (get (type-of self) 'tk-class-options)
(loop with all = (remove-duplicates (call-next-method) :key 'second)
for old in (when (tile? self)
(case (type-of self)
(label '(pady padx height indicatoron relief tk-label))
(otherwise '(pady padx #+hmmm height indicatoron relief tk-label))));;
do (setf old (delete old all :key 'car))
finally (return all))))))
(defun tk-config-option (self slot-name)
(second (assoc slot-name (tk-class-options self))))
(defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp cell)
(declare (ignorable old-value cell))
(when old-value-boundp ;; initial propagation to Tk happens during make-tk-instance
(bwhen (tco (tk-config-option self slot-name)) ;; (get slot-name 'tk-config-option))
(tk-configure self (string tco) (or new-value "")))))
(defun tk-configurations (self)
(loop with configs
for (slot-name tk-option) in (tk-class-options self)
when tk-option
do (bwhen (slot-value (funcall slot-name self)) ;; must go thru accessor with Cells, not 'slot-value
(setf configs (nconc (list tk-option (tk-send-value slot-value)) configs)))
finally (return configs)))