/[cells]/Celtk/timer.lisp
ViewVC logotype

Contents of /Celtk/timer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Mon Jan 29 06:48:41 2007 UTC (7 years, 2 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.12: +1 -1 lines
Rough Tile support and first primitive QuickTimeTcl stuff.
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

  ViewVC Help
Powered by ViewVC 1.1.5