diff --git a/demo/bitmap-editor.lisp b/demo/bitmap-editor.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ae3065612513cdbcf86b7614286491d756966dcc --- /dev/null +++ b/demo/bitmap-editor.lisp @@ -0,0 +1,192 @@ +;; -*- mode: common-lisp; package: clim-demo -*- +;; +;; -[]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; +;; $fiHeader$ + + +(in-package :clim-demo) + +(define-application-frame bitmap-editor () + ((rows :initarg :rows :initform 8) + (cell-size :initarg :cell-size :initform 10) + (columns :initarg :columns :initform 8) + (array :initarg :array :initform nil) + (current-color :initarg :current-color :initform 0) + (colors :initarg :colors :initform + (list +background-ink+ +foreground-ink+))) + (:panes + (palette :accept-values :scroll-bars :vertical :width :compute :height :compute + :display-function '(accept-values-pane-displayer + :displayer display-palette)) + (edit-pane :application :scroll-bars :both :width :compute :height :compute) + (pattern-pane :application :scroll-bars nil :width :compute :height :compute)) + (:layouts (default (horizontally () palette edit-pane pattern-pane)))) + +(defun display-palette (frame stream) + (with-slots (colors current-color) frame + (flet ((display-color (object stream) + (with-room-for-graphics (stream) + (draw-rectangle* stream 0 0 30 10 :ink object)))) + (setf current-color + (position + (accept `((completion ,colors) + :name-key ,#'identity + :printer ,#'display-color) + :view '(clim-internals::radio-box-view :orientation + :vertical :toggle-button-options (:indicator-type nil)) + :stream stream + :default (nth current-color colors) + :prompt "Colors") + colors)) + (terpri stream) + (accept-values-command-button (stream) + "Add Color" + (add-color-to-palette frame)) + (terpri stream) + (accept-values-command-button (stream) + "Edit Color" + (replace-current-color frame)) + (terpri stream) + (accept-values-command-button (stream) + "Delete Color" + (delete-current-color frame))))) + +(defun replace-current-color (frame) + ;;--- Exercise for the read + ) + +(defun delete-current-color (frame) + ;;--- Exercise for the reader + ) + +(defun add-color-to-palette (frame) + (let ((fr (make-application-frame 'color-chooser))) + (run-frame-top-level fr) + (with-slots (colors) frame + (setq colors (append colors (list (color fr))))))) + + +(define-bitmap-editor-command (com-display-options :menu t) + () + (let* ((frame *application-frame*) + (rows (slot-value frame 'rows)) + (columns (slot-value frame 'columns)) + (cell-size (slot-value frame 'cell-size)) + (view '(clim-internals::slider-view :show-value-p t))) + (accepting-values (*query-io* :own-window t :label "Editor options") + (setq rows (accept '(integer 1 256) + :view view + :default rows + :prompt "Rows" + :stream *query-io*)) + (terpri *query-io*) + (setq columns (accept '(integer 1 256) + :view view + :default columns + :prompt "Columns" + :stream *query-io*)) + (terpri *query-io*) + (setq cell-size (accept '(integer 10 100) + :view view + :default cell-size + :prompt "Cell Size" + :stream *query-io*)) + (terpri *query-io*)) + (setf (slot-value frame 'rows) rows + (slot-value frame 'columns) columns + (slot-value frame 'cell-size) cell-size + (slot-value frame 'array) + (adjust-array (slot-value frame 'array) (list rows columns) + :initial-element 0)) + (display-everything frame))) + +(defmethod initialize-instance :after ((frame bitmap-editor) &key) + (with-slots (rows columns array) frame + (setf array (make-array (list rows columns) :initial-element 0)))) + +(defmethod display-grid (frame pane) + (with-slots (rows columns cell-size) frame + (let ((maxx (* rows (1+ cell-size))) + (maxy (* columns (1+ cell-size)))) + (dotimes (i (1+ rows)) + (draw-line* pane 0 (* i (1+ cell-size)) maxx (* i (1+ cell-size)))) + (dotimes (i (1+ columns)) + (draw-line* pane (* i (1+ cell-size)) 0 (* i (1+ cell-size)) maxy))))) + +(defmethod display-cells (frame pane) + (with-slots (rows columns cell-size) frame + (dotimes (i rows) + (dotimes (j columns) + (display-cell frame pane i j))))) + +(define-presentation-type bitmap-editor-cell ()) + +(define-presentation-method presentation-typep (object (type bitmap-editor-cell)) + (and (listp object) (= 2 (length object)))) + +(defun display-cell (frame pane i j) + (with-slots (cell-size array colors) frame + (let ((x (* j (1+ cell-size))) + (y (* i (1+ cell-size)))) + (with-output-as-presentation (pane (list i j) 'bitmap-editor-cell) + (draw-rectangle* pane (+ x 2) + (+ y 2) + (+ x (- cell-size 2)) + (+ y (- cell-size 2)) + :ink (nth (aref array i j) colors) + :filled t))))) + +(defun display-pattern (frame) + (let ((stream (get-frame-pane frame 'pattern-pane))) + (with-slots (array rows columns colors) frame + (window-clear stream) + (surrounding-output-with-border (stream) + (draw-rectangle* stream 10 10 (+ 10 rows) (+ 10 columns) + :ink + (make-pattern array colors)))))) + +(defmethod run-frame-top-level :before ((frame bitmap-editor)) + (display-everything frame)) + +(defun display-everything (frame) + (let ((stream (get-frame-pane frame 'edit-pane))) + (window-clear stream) + (display-grid frame stream) + (display-cells frame stream) + (display-pattern frame))) + +(define-presentation-to-command-translator toggle-cell + (bitmap-editor-cell com-toggle-cell bitmap-editor :gesture :select) + (presentation object) + (list presentation object)) + +(define-bitmap-editor-command com-toggle-cell + ((presentation 'presentation) + (cell 'bitmap-editor-cell)) + (let ((frame *application-frame*)) + (destructuring-bind (i j) cell + (with-slots (array current-color) frame + (setf (aref array i j) current-color)) + (let ((stream (get-frame-pane frame 'edit-pane))) + (erase-output-record presentation stream) + (display-cell frame stream i j) + (display-pattern frame))))) diff --git a/demo/process-browser.lisp b/demo/process-browser.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8f4475fedf7f568a6cb4c1611a25b2d56514cf73 --- /dev/null +++ b/demo/process-browser.lisp @@ -0,0 +1,197 @@ +;; -*- mode: common-lisp; package: clim-demo -*- +;; +;; -[]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; +;; $fiHeader$ + + +(in-package :clim-demo) + +(define-application-frame process-browser () + ((timer :accessor process-browser-timer :initform nil) + (delay :initarg :delay :accessor process-browser-delay)) + (:panes + (processes :application + :incremental-redisplay '(t :check-overlapping nil) + :display-function 'display-processes + :width :compute :height :compute)) + (:layouts + (default processes)) + (:default-initargs :delay 5)) + +(defmethod read-frame-command :around ((frame process-browser) &key) + (with-accessors ((timer process-browser-timer)) frame + (unwind-protect + (progn + (install-process-browser-timer frame) + (call-next-method)) + (when timer (clim-utils::delete-timer timer))))) + +(defun install-process-browser-timer (frame) + (with-accessors ((timer process-browser-timer) + (delay process-browser-delay)) frame + (when timer (clim-utils::delete-timer timer)) + (setq timer (clim-internals::make-command-timer frame 'com-update-process-browser nil + delay)))) + +(define-process-browser-command (com-change-delay-browser :menu t) + () + (let ((frame *application-frame*)) + (with-accessors ((timer process-browser-timer) + (delay process-browser-delay)) frame + (accepting-values (*query-io* :own-window t) + (setf delay (accept '(integer 1 *) + :prompt "Enter new delay" + :default delay + :stream *query-io*)) + (terpri *query-io*))))) + +(define-process-browser-command com-update-process-browser + () + ;;-- We have to do this because of the asynchronous updates + (unhighlight-highlighted-presentation *standard-output*)) + +(define-process-browser-command (com-refresh-process-browser :menu t) + () + (window-clear *standard-output*)) + +#+:composer-v2.0 +(define-process-browser-command com-inspect-process + ((process 'mp::process :gesture :select)) + (wt::winspect process)) + +(defun display-processes (frame pane &key &allow-other-keys) + (declare (ignore frame)) + (with-text-size (t :small) + (let ((*standard-output* pane)) + (formatting-table () + (with-text-face (t :bold) + (updating-output (t :unique-id 'headings) + (formatting-row () + (formatting-cell () (write-string "P")) + (formatting-cell () (write-string "Dis")) + (formatting-cell () (write-string "Sec")) + (formatting-cell () (write-string "dSec")) + (formatting-cell () (write-string "Priority")) + (formatting-cell () (write-string "State")) + (formatting-cell () (write-string "Name,Whostate,Arrest"))))) + ;;-- snarfed from toplevel.cl + (let* ((processes mp:*all-processes*) + (processes + (sort (mp:without-scheduling ;assure consistent data + (mapcar #'(lambda (p) + (let* ((times (mp::process-times-resumed p)) + (dtimes (- times (mp::process-times-resumed-1 p))) + (msec (mp::process-cpu-msec-used p)) + (dmsec (- msec (mp::process-cpu-msec-used-1 p)))) + (prog1 (list* dtimes msec dmsec p) + (setf (mp::process-times-resumed-1 p) times + (mp::process-cpu-msec-used-1 p) msec)))) + processes)) + #'>= :key #'caddr))) + (dolist (p processes) + (destructuring-bind (times-resumed msec-used msec-used-d . process) p + (let ((profilep + (let ((stack-group (mp::process-stack-group process))) + (and stack-group + (mp::profile-stack-group-p stack-group))))) + (updating-output (t :unique-id process + :cache-test #'equal + :cache-value + (list p + profilep + (mp::process-active-p process) + (mp::process-runnable-p process) + (mp::process-wait-function process) + (mp::process-name process) + (mp::process-whostate process) + (mp::process-arrest-reasons process))) + (formatting-row () + (with-output-as-presentation (t + process + 'mp::process + :single-box t) + (updating-output (t :cache-value profilep) + (formatting-cell () + (princ profilep))) + (updating-output (t :cache-value times-resumed) + (formatting-cell () + (princ times-resumed))) + (updating-output (t :cache-value msec-used) + (formatting-cell () + (princ (round msec-used 1000)))) + (updating-output (t :cache-value msec-used-d) + (formatting-cell () + (princ (/ msec-used-d 1000.0)))) + (updating-output (t :cache-value (mp::process-priority process)) + (formatting-cell () + (princ (mp::process-priority process)))) + + (let ((state + (cond ((not (mp::process-active-p process)) "inactive") + ((mp::process-runnable-p process) "runnable") + ((mp::process-wait-function process) "waiting ") + (t " ? ")))) + (updating-output (t :cache-value state :cache-test #'equal) + (formatting-cell () + (princ state)))) + + (updating-output (t :cache-value + (mp::process-name process) + :cache-test #'equal) + (formatting-cell () + (with-text-face (t :bold) + (princ (mp::process-name process))))) + + (updating-output (t :cache-value (mp::process-whostate process)) + (formatting-cell () + (princ (mp::process-whostate + process)))) + + (updating-output (t :cache-value (mp::process-arrest-reasons process) + :cache-test #'equal) + (formatting-cell () + (when (mp::process-arrest-reasons process) + (princ (mp::process-arrest-reasons process)))))))))))))))) + +(defvar *process-browsers* nil) + +(defun do-process-browser (&key (port (find-port)) (force nil)) + (let* ((framem (find-frame-manager :port port)) + (frame + (let* ((entry (assoc port *process-browsers*)) + (frame (cdr entry))) + (when (or force (null frame)) + (setq frame (make-application-frame 'process-browser + :frame-manager framem))) + (if entry + (setf (cdr entry) frame) + (push (cons port frame) *process-browsers*)) + frame))) + (run-frame-top-level frame))) + +(define-demo "Process Browser" do-process-browser) + + + + + + diff --git a/tk-silica/xm-dialogs.lisp b/tk-silica/xm-dialogs.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8ca13f30fbcc3ae529b6ececba3553b4613479b8 --- /dev/null +++ b/tk-silica/xm-dialogs.lisp @@ -0,0 +1,269 @@ +;; -*- mode: common-lisp; package: clim-internals -*- +;; +;; -[]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; +;; $fiHeader$ + + +(in-package :clim-internals) + +(defmethod frame-manager-accepting-values-frame-class ((framem xm-silica::motif-frame-manager)) + 'motif-accept-values-own-window) + +(define-application-frame motif-accept-values-own-window (accept-values-own-window) + () + (:pane + (with-slots (stream own-window exit-button-stream) *application-frame* + (vertically () + (progn + (setq stream + (make-instance 'accept-values-stream + :stream (setf own-window + (make-pane 'clim-stream-pane + :initial-cursor-visibility :off)))) + own-window) + (make-pane 'silica::separator :orientation :horizontal) + (setf exit-button-stream + (make-pane 'clim-stream-pane + :initial-cursor-visibility nil))))) + (:menu-bar nil) + (:top-level (accept-values-top-level)) + (:command-table accept-values) + (:command-definer nil)) + +;;;---- The rest of what in here is dreaming right now +;;;---- It would be nice to use more + +;#+ignore +;(define-application-frame xm-silica::motif-accepting-values-frame (accept-values-own-window) +; () +; (:panes +; (control-area :application :scroll-bars nil) +; (action-area (make-pane 'xm-silica::motif-form-pane))) +; (:menu-bar nil) +; (:top-level (accept-values-top-level)) +; (:command-table accept-values) +; (:command-definer nil) +; (:layouts +; (:default +; (let ((frame *application-frame*) +; (view +gadget-dialog-view+)) +; (let ((vp +; (make-pane 'xm-silica::motif-paned-pane +; :children (list control-area action-area)))) +; (let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame view))) +; (with-slots (exit-boxes) frame +; (dolist (exit-box exit-boxes) +; (let* ((value (if (consp exit-box) (car exit-box) exit-box)) +; (label (or (if (consp exit-box) (second exit-box)) +; (second (assoc value labels))))) +; (make-pane 'push-button +; :parent action-area +; :label label +; :client frame :id value +; :activate-callback +; #'handle-exit-box-callback)))) +; (setf (slot-value action-area 'xm-silica::fraction-base) +; (1+ (* 2 (length labels)))) +; (setf (slot-value action-area 'xm-silica::attachments) +; (let ((i 0)) +; (mapcar #'(lambda (label) +; (declare (ignore label)) +; (prog1 +; `(,i :top-attachment :form +; :bottom-attachment :form +; :left-attachment :position +; :left-position ,(1+ (* 2 i)) +; :right-attachment :position +; :right-position ,(+ 2 (* 2 i))) +; (incf i))) +; labels))) +; +; vp)))))) +; +; +; +; +;(defmethod generate-panes :after ((framem standard-frame-manager) +; (frame xm-silica::motif-accepting-values-frame)) +; (setf (slot-value frame 'stream) +; (make-instance 'accept-values-stream +; :stream (setf (slot-value frame 'own-window) +; (get-frame-pane frame 'control-area)))) +; (setf (slot-value frame 'exit-button-stream) nil)) +; +;(defmethod display-exit-boxes ((frame xm-silica::motif-accepting-values-frame) +; stream +; (view view)) +; ;;-- Nothing should have changed +; nil) +; +;;;; Need to hook up the constraint resources and set the min-max size +;;;; of the action-pane to be just large enough to contain the buttons. +; +;(defmethod accept-values-top-level ((frame xm-silica::motif-accepting-values-frame) &rest args) +; (declare (ignore args)) +; ;; this might want to use table-formatting or equivalent +; ;; to make sure that the rows line up properly. +; ;; This requires formatting-table and friends to return their bodies' values properly. +; (with-slots (stream continuation resynchronize-every-pass check-overlapping +; selected-item initially-select-query-identifier +; own-window own-window-x-position own-window-y-position +; own-window-width own-window-height +; own-window-right-margin own-window-bottom-margin +; exit-button-stream) frame +; +; (unless own-window (return-from accept-values-top-level (call-next-method))) +; +; (let* ((original-view (stream-default-view stream)) +; (return-values nil) +; (initial-query nil) +; exit-button-record +; avv avv-record) +; (letf-globally (((stream-default-view stream) +; (frame-manager-dialog-view (frame-manager frame))) +; ((cursor-state (stream-text-cursor stream)) nil)) +; (labels ((run-continuation (stream avv-record) +; (setf (slot-value stream 'avv-record) avv-record) +; (setf (slot-value stream 'avv-frame) frame) +; (with-output-recording-options (stream :draw nil :record t) +; (setq return-values (multiple-value-list +; (let ((*application-frame* *avv-calling-frame*)) +; (funcall continuation stream)))) +; (unless own-window +; (display-exit-boxes frame stream +; (stream-default-view stream))))) +; (run-avv () +; (when (and initially-select-query-identifier +; (setq initial-query +; (find-query avv-record +; (car initially-select-query-identifier)))) +; (if (cdr initially-select-query-identifier) +; (com-modify-avv-choice initial-query) +; (com-edit-avv-choice initial-query)) +; (redisplay avv stream :check-overlapping check-overlapping)) +; (loop +; (let ((command +; (let ((command-stream (slot-value stream 'stream))) +; ;; While we're reading commands, restore the view +; ;; to what it was before we started. +; (letf-globally (((stream-default-view command-stream) +; original-view)) +; (read-frame-command frame :stream command-stream))))) +; (if (and command (not (keyboard-event-p command))) +; (execute-frame-command frame command) +; (beep stream))) +; (with-deferred-gadget-updates +; (when (or resynchronize-every-pass +; (slot-value avv-record 'resynchronize)) +; ;; When the user has asked to resynchronize every pass, that +; ;; means we should run the continuation an extra time to see +; ;; that all visible stuff is up to date. That's all! +; (with-output-recording-options (stream :draw nil) +; (redisplay avv stream :check-overlapping check-overlapping))) +; (setf (slot-value avv-record 'resynchronize) nil) +; +;; (when exit-button-record +;; (redisplay exit-button-record exit-button-stream)) +; +; (redisplay avv stream :check-overlapping check-overlapping) +; +; (when (ecase (frame-resizable frame) +; ((nil) nil) +; ((t) t) +; (:grow +; (and own-window +; (multiple-value-bind (width height) +; (bounding-rectangle-size +; (stream-output-history own-window)) +; (multiple-value-bind (vwidth vheight) +; (bounding-rectangle-size +; (or (pane-viewport own-window) own-window)) +; (or (> width vwidth) (> height vheight))))))) +; (size-panes-appropriately))))) +; +; (size-panes-appropriately () +; (changing-space-requirements () +; ;; We really want to specify the min/max sizes of +; ;; the exit-button pane +; ;; also +;; (when exit-button-stream +;; (size-frame-from-contents exit-button-stream +;; :size-setter +;; #'(lambda (pane w h) +;; (change-space-requirements +;; pane +;; :width w :min-width w :max-width w +;; :height h :min-height h :max-height h)))) +; (when own-window +; (size-frame-from-contents own-window +; :width own-window-width +; :height own-window-height +; :right-margin own-window-right-margin +; :bottom-margin own-window-bottom-margin))))) +; (declare (dynamic-extent #'run-continuation #'run-avv +; #'size-panes-appropriately)) +; (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog") +; (setq avv +; (updating-output (stream) +; (setq avv-record +; (with-end-of-line-action (stream :allow) +; (with-end-of-page-action (stream :allow) +; (with-new-output-record +; (stream 'accept-values-output-record avv-record) +; (run-continuation stream avv-record))))))) +; ;; In own window dialogs the buttons are displayed separately +;; (when (and own-window exit-button-stream) +;; (setq exit-button-record +;; (updating-output (exit-button-stream) +;; (with-end-of-line-action (exit-button-stream :allow) +;; (with-end-of-page-action (exit-button-stream :allow) +;; (display-exit-boxes frame exit-button-stream +;; (stream-default-view stream))))))) +; +; (unwind-protect +; (cond (own-window +; (size-panes-appropriately) +; (multiple-value-bind (x y) +; #+++ignore (pointer-position (port-pointer (port own-window))) +; #---ignore (values 100 100) +; (when (and own-window-x-position own-window-y-position) +; (setq x own-window-x-position +; y own-window-y-position)) +; (position-sheet-carefully +; (frame-top-level-sheet (pane-frame own-window)) x y)) +; (window-expose own-window) +; (with-input-focus (own-window) +; (when exit-button-record +; (replay exit-button-record exit-button-stream)) +; (replay avv stream) +; (run-avv))) +; (t +; ;; Ensure that bottom of the AVV is visible. I think that +; ;; this is OK even if the AVV is bigger than the viewport. +; (move-cursor-beyond-output-record (slot-value stream 'stream) avv) +; (stream-ensure-cursor-visible stream) +; (replay avv stream) +; (run-avv))) +; (deactivate-all-gadgets avv-record) +; (unless own-window +; (move-cursor-beyond-output-record (slot-value stream 'stream) avv)))) +; (values-list return-values)))))) diff --git a/utils/timers.lisp b/utils/timers.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ca432ab80f428bd6f7b4230aac7d766e12a706f7 --- /dev/null +++ b/utils/timers.lisp @@ -0,0 +1,116 @@ +;; -*- mode: common-lisp; package: clim-utils -*- +;; +;; -[]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; +;; $fiHeader$ + +(in-package :clim-utils) + +;;;---- Perhaps this should be elsewhere +;;; Implementation of timers +;;; Its lame but its ugly. +;;; You can: +;;; make-instance 'timer +;;; queue-timer +;;; delete-time + +(defclass timer () + ((delay :initarg :delay :reader timer-delay) + (repeat :initarg :repeat :initform nil :reader timer-repeat) + (function :initarg :function :reader timer-function) + (when :accessor timer-when)) + ) + +(defvar *timer-input-queue* (make-queue)) + +(defun add-timer (timer) + (ensure-timer-process) + (setf (timer-when timer) + (+ (get-internal-real-time) + (* internal-time-units-per-second + (timer-delay timer)))) + (queue-put *timer-input-queue* timer)) + +(defun delete-timer (timer) + (queue-put *timer-input-queue* `(:delete ,timer))) + +(defvar *timers* nil) + +(defvar *timer-process* nil) + +(defun queue-process-function () + (unwind-protect + (progn + (setq *timer-process* (Current-process)) + (flet ((add-timer-to-queue (timer) + (setq *timers* (merge 'list (list timer) *timers* '< :key #'timer-when)))) + (declare (dynamic-extent #'add-timer-to-queue)) + (loop + (let ((head (car *timers*))) + + (if head + (let* ((time-now (get-internal-real-time)) + (time-to-wait (- (timer-when head) time-now))) + (process-wait-with-timeout + "Waiting" + (float (/ time-to-wait internal-time-units-per-second)) + #'(lambda () (not (queue-empty-p *timer-input-queue*))))) + (process-wait + "Waiting" + #'(lambda () (not (queue-empty-p *timer-input-queue*))))) + + + (loop + (let ((head (queue-pop *timer-input-queue*))) + (etypecase head + (null (return nil)) + (timer (add-timer-to-queue head)) + (cons + (ecase (first head) + (:delete (setf *timers* (delete (second head) *timers*)))))))) + + (loop + (unless *timers* (return nil)) + (let ((time-now (get-internal-real-time)) + (timer (car *timers*))) + (if (< (timer-when timer) time-now) + (progn + (pop *timers*) + (funcall (timer-function timer) timer) + (when (timer-repeat timer) + (setf (timer-when timer) + (+ (get-internal-real-time) + (* internal-time-units-per-second + (timer-repeat timer)))) + (add-timer-to-queue timer))) + (return nil)))))))) + (setq *timer-process* nil))) + +(defun ensure-timer-process () + (unless *timer-process* + (make-process #'queue-process-function :name "Timer"))) + + + + + + +