timer.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 ;;; --- timers ----------------------------------------
  20
  21 (in-package :Celtk)
  22
  23 (defun never-unchanged (new old) (declare (ignore new old)))
  24
  25 ;;;
  26 ;;; Now, not one but three incredibly hairy gyrations Cells-wise:
  27 ;;;
  28 ;;;    - repeat cannot be ephemeral, but we want repeated (setf (^repeat) 20)'s each to fire,
  29 ;;;      so we specify an unchanged-if value that always "no", lying to get propagation
  30 ;;;
  31 ;;;    - the executions rule is true obfuscated code. It manages to reset the count to zero
  32 ;;;      on repeated (setf ... 20)'s because on the second repetition we know we will hit the rule
  33 ;;;      with repeat non-null (20, in fact) and the ephemeral executed will be nil (because it is
  34 ;;;      only non-nil during propagation of (setf (executed...) t). not for Cell noobs.
  35 ;;;
  36 ;;;    - holy toledo. The /rule/ for after-factory sends the after command to Tk itself! I could just
  37 ;;;      return a list of the delay and the callback and have an observer dispatch it, but it would
  38 ;;;      have to so so exactly as the rule does, by dropping it in the deferred client queue.
  39 ;;;      In a sense I am starting here to leverage Cells3 queues to simplify things. Mind you, if
  40 ;;;      Timer evolves to where we let the client write its own after factory, we might want to
  41 ;;;      factor out the actual dispatch into an observer to make it transparent (assuming that is
  42 ;;;      not why they are supplying their own after-factory.
  43 ;;;
  44 ;;; Timer is totally a work-in-progress with much development ahead.
  45 ;;;
  46
  47 (eval-now!
  48   (export '(repeat ^repeat)))
  49
  50 (defmodel timer ()
  51   ((cancel-id :cell nil :initarg :cancel-id :accessor cancel-id :initform nil
  52      :documentation "Generated by TCL After command itself")
  53    (tag :cell nil :initarg :tag :accessor tag :initform :anon
  54      :documentation "A debugging aid")
  55    (elapsed :cell nil :initarg :elapsed :accessor elapsed :initform 0)
  56    (state :initarg :state :accessor state :initform (c-in :on)
  57      :documentation "Turn off to stop, regardless of REPEAT setting") ;; possibly redundant
  58    (action :initform nil :initarg :action :accessor action
  59      :documentation "A function invoked when the TCL AFTER executes (is dispatched)")
  60    (delay :initform 0 :initarg :delay :accessor delay
  61      :documentation "Millisecond interval supplied as is to TCL AFTER")
  62    (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged
  63      :documentation "t = run continuously, nil = pause, a number N = repeat N times")
  64    (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)
  65      :documentation "Internal boolean: set after an execution")
  66    (executions :initarg :executions :accessor executions
  67      :documentation "Number of times timer has had its action run since the last change to  the repeat slot"
  68      :initform (c? (eko (nil ">>> executions")
  69                      (if (null (^repeat))
  70                        0 ;; ok, repeat is off, safe to reset the counter here
  71                      (if (^executed)
  72                          (1+ (or .cache 0)) ;; obviously (.cache is the prior value, and playing it safe in case unset)
  73                        0))))) ;; hunh? executed is ephemeral. we are here only if repeat is changed, so reset
  74
  75    (on-command :reader on-command
  76      :initform (lambda (self)
  77                  (unless (mdead self)
  78                    (trc nil "timer on-command dispatched!!!!!" self)
  79                    (when (eq (^state) :on)
  80                      (assert (^action))
  81                      (funcall (^action) self)
  82                      (setf (^executed) t)))))
  83
  84    (after-factory :reader after-factory
  85      :initform (c? (bwhen (rpt (when (eq (^state) :on)
  86                                (^repeat)))
  87                    (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution
  88                      (when (zerop (^executions))
  89                        (setf (elapsed self) (now)))
  90                      (when (if (numberp rpt)
  91                                (< (^executions) rpt)
  92                              rpt) ;; playing it safe/robust: redundant with initial bwhen check that rpt is not nil
  93                        (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters
  94                          (set-timer self (^delay))))))))))
  95
  96 (defmethod not-to-be :before ((self timer))
  97   (setf (state self) :off))
  98
  99 (defobserver state ((self timer))
 100   (unless (eq new-value :on)
 101     (cancel-timer self)))
 102
 103 (defun set-timer (self time)
 104   (let ((callback-id (symbol-name (gentemp "AFTER"))))
 105     (setf (gethash callback-id (dictionary *tkw*)) self)
 106     (setf (cancel-id self) (tk-eval "after ~a {do-on-command ~a}" time callback-id))))
 107
 108 (defun cancel-timer (timer)
 109   (when (cancel-id timer)
 110     (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed
 111
 112 (defobserver timers ((self tk-object) new-value old-value)
 113   (dolist (k (set-difference old-value new-value))
 114     (setf (state k) :off))) ;; actually could be anything but :on
 115
 116
 117