/
timer.lisp
executable file
·117 lines (95 loc) · 5.47 KB
/
timer.lisp
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
;; -*- 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.
|#
;;; --- timers ----------------------------------------
(in-package :celtk)
(defun never-unchanged (new old) (declare (ignore new old)))
;;;
;;; Now, not one but three incredibly hairy gyrations Cells-wise:
;;;
;;; - repeat cannot be ephemeral, but we want repeated (setf (^repeat) 20)'s each to fire,
;;; so we specify an unchanged-if value that always "no", lying to get propagation
;;;
;;; - the executions rule is true obfuscated code. It manages to reset the count to zero
;;; on repeated (setf ... 20)'s because on the second repetition we know we will hit the rule
;;; with repeat non-null (20, in fact) and the ephemeral executed will be nil (because it is
;;; only non-nil during propagation of (setf (executed...) t). not for Cell noobs.
;;;
;;; - holy toledo. The /rule/ for after-factory sends the after command to Tk itself! I could just
;;; return a list of the delay and the callback and have an observer dispatch it, but it would
;;; have to so so exactly as the rule does, by dropping it in the deferred client queue.
;;; In a sense I am starting here to leverage Cells3 queues to simplify things. Mind you, if
;;; Timer evolves to where we let the client write its own after factory, we might want to
;;; factor out the actual dispatch into an observer to make it transparent (assuming that is
;;; not why they are supplying their own after-factory.
;;;
;;; Timer is totally a work-in-progress with much development ahead.
;;;
(eval-now!
(export '(repeat ^repeat)))
(defmodel timer ()
((cancel-id :cell nil :initarg :cancel-id :accessor cancel-id :initform nil
:documentation "Generated by TCL After command itself")
(tag :cell nil :initarg :tag :accessor tag :initform :anon
:documentation "A debugging aid")
(elapsed :cell nil :initarg :elapsed :accessor elapsed :initform 0)
(state :initarg :state :accessor state :initform (c-in :on)
:documentation "Turn off to stop, regardless of REPEAT setting") ;; possibly redundant
(action :initform nil :initarg :action :accessor action
:documentation "A function invoked when the TCL AFTER executes (is dispatched)")
(delay :initform 0 :initarg :delay :accessor delay
:documentation "Millisecond interval supplied as is to TCL AFTER")
(repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged
:documentation "t = run continuously, nil = pause, a number N = repeat N times")
(executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)
:documentation "Internal boolean: set after an execution")
(executions :initarg :executions :accessor executions
:documentation "Number of times timer has had its action run since the last change to the repeat slot"
:initform (c? (eko (nil ">>> executions")
(if (null (^repeat))
0 ;; ok, repeat is off, safe to reset the counter here
(if (^executed)
(1+ (or .cache 0)) ;; obviously (.cache is the prior value, and playing it safe in case unset)
0))))) ;; hunh? executed is ephemeral. we are here only if repeat is changed, so reset
(on-command :reader on-command
:initform (lambda (self)
(unless (mdead self)
(trc nil "timer on-command dispatched!!!!!" self)
(when (eq (^state) :on)
(assert (^action))
(funcall (^action) self)
(setf (^executed) t)))))
(after-factory :reader after-factory
:initform (c? (bwhen (rpt (when (eq (^state) :on)
(^repeat)))
(when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution
(when (zerop (^executions))
(setf (elapsed self) (now)))
(when (if (numberp rpt)
(< (^executions) rpt)
rpt) ;; playing it safe/robust: redundant with initial bwhen check that rpt is not nil
(with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters
(set-timer self (^delay))))))))))
(defmethod not-to-be :before ((self timer))
(setf (state self) :off))
(defobserver state ((self timer))
(unless (eq new-value :on)
(cancel-timer self)))
(defun set-timer (self time)
(let ((callback-id (symbol-name (gentemp "AFTER"))))
(setf (gethash callback-id (dictionary *tkw*)) self)
(setf (cancel-id self) (tk-eval "after ~a {do-on-command ~a}" time callback-id))))
(defun cancel-timer (timer)
(when (cancel-id timer)
(tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed
(defobserver timers ((self tk-object) new-value old-value)
(dolist (k (set-difference old-value new-value))
(setf (state k) :off))) ;; actually could be anything but :on