tk-object.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Celtk -- Cells, Tcl, and Tk
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19 (in-package :Celtk)
  20
  21 ;;; --- tk-object ------------------
  22
  23
  24 (defmodel tk-object (model)
  25   ((.md-name :cell nil :initform (gentemp "TK") :initarg :id)
  26    (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)
  27
  28    (timers :owning t :initarg :timers :accessor timers :initform nil)
  29    (on-command :initarg :on-command :accessor on-command :initform nil)
  30    (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil
  31      :documentation "Long story. Tcl C API weak for keypress events. This gets dispatched
  32 eventually thanks to DEFCOMMAND")
  33    (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
  34    (user-errors :initarg :user-errors :accessor user-errors :initform nil)
  35    (tile? :initform t :cell nil :reader tile? :initarg :tile?))
  36   (:documentation "Root class for widgets and (canvas) items"))
  37
  38 (export! valid? ^valid?)
  39
  40 (defun valid? (self)
  41   (not (^user-errors)))
  42
  43 (defmacro ^valid? ()
  44   '(valid? self))
  45
  46 (defmethod md-awaken :before ((self tk-object))
  47   (make-tk-instance self))
  48
  49 (defmethod parent-path ((self tk-object)) (path self))
  50
  51 ;;; --- deftk --------------------
  52
  53 (defmacro deftk (class superclasses
  54                          (&rest std-slots)
  55                          &rest defclass-options)
  56   (destructuring-bind (&optional tk-class &rest tk-options)
  57       (cdr (find :tk-spec defclass-options :key 'car))
  58
  59     (setf tk-options (tk-options-normalize tk-options))
  60
  61     `(eval-now!
  62      (defmodel ,class ,(or superclasses '(tk-object))
  63        (,@(append std-slots (loop for (slot-name nil) in tk-options
  64                                 collecting `(,slot-name :initform nil
  65                                               :initarg ,(intern (string slot-name) :keyword)
  66                                               :accessor ,slot-name))))
  67        ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car)
  68        (:default-initargs
  69            ,@(when tk-class `(:tk-class ',tk-class))
  70          ,@(cdr (find :default-initargs defclass-options :key 'car))))
  71      (defmethod tk-class-options append ((self ,class))
  72        ',tk-options)
  73      (export ',(loop for (slot nil) in tk-options
  74                    nconcing (list slot (intern (conc$ "^" slot)))))
  75      (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits)
  76        `(make-instance ',',class
  77           :fm-parent *parent*
  78           ,@inits)))))
  79
  80 (defun tk-options-normalize (tk-options)
  81   "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))"
  82   (loop for tk-option-def in tk-options
  83       for slot-name = (intern (de- (if (atom tk-option-def)
  84                                        tk-option-def (car tk-option-def))))
  85       collecting (list slot-name (if (atom tk-option-def)
  86                                      tk-option-def (cadr tk-option-def)))))
  87
  88 (eval-now!
  89   (defun de- (sym)
  90     (remove #\- (symbol-name sym) :end 1)))
  91
  92 (defgeneric tk-class-options (self)
  93   (:method-combination append)
  94   (:method :around (self)
  95     (or (get (type-of self) 'tk-class-options)
  96              (setf (get (type-of self) 'tk-class-options)
  97                (loop with all = (remove-duplicates (call-next-method) :key 'second)
  98                      for old in (when (tile? self)
  99                                   (case (type-of self)
 100                                     (label '(pady padx height indicatoron relief tk-label))
 101                                     (otherwise '(pady padx #+hmmm height indicatoron relief tk-label))));;
 102                      do (setf old (delete old all :key 'car))
 103                      finally (return all))))))
 104
 105 (defun tk-config-option (self slot-name)
 106   (second (assoc slot-name (tk-class-options self))))
 107
 108 (defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp)
 109   (declare (ignorable old-value))
 110   (when old-value-boundp ;; initial propagation to Tk happens during make-tk-instance
 111     (bwhen (tco (tk-config-option self slot-name)) ;; (get slot-name 'tk-config-option))
 112       (tk-configure self (string tco) (or new-value "")))))
 113
 114 (defun tk-configurations (self)
 115   (loop with configs
 116       for (slot-name tk-option) in (tk-class-options self)
 117       when tk-option
 118       do (bwhen (slot-value (funcall slot-name self)) ;; must go thru accessor with Cells, not 'slot-value
 119            (setf configs (nconc (list tk-option (tk-send-value slot-value)) configs)))
 120       finally (return configs)))
 121