Skip to content
This repository
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

executable file 120 lines (93 sloc) 5.037 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
;; -*- 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
(http://opensource.franz.com/preamble.html), known as the LLGPL.

This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

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)
   (on-double-click-1 :initarg :on-double-click-1 :accessor on-double-click-1 :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))
    
    `(eval-now!
      (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)
        (:default-initargs
            ,@(when tk-class `(:tk-class ',tk-class))
          ,@(cdr (find :default-initargs defclass-options :key 'car))))
      (defmethod tk-class-options append ((self ,class))
        ',tk-options)
      (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*
           ,@inits)))))

(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)))))

(eval-now!
  (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 all (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)))
Something went wrong with that request. Please try again.