From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 17 Jan 2016 00:47:51 +0000 (-0700)
Subject: Add MONITOR-WORLD Edwin command displaying an animated world-report.
X-Git-Tag: mit-scheme-pucked-9.2.12~373^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0eb7f2ec95c831bc92bbe0ac9aa2c4da09b5a3a3;p=mit-scheme.git
Add MONITOR-WORLD Edwin command displaying an animated world-report.
---
diff --git a/src/edwin/decls.scm b/src/edwin/decls.scm
index acf41a14f..bbf5e7079 100644
--- a/src/edwin/decls.scm
+++ b/src/edwin/decls.scm
@@ -236,6 +236,7 @@ USA.
"winout"
"xcom"
"win32com"
+ "world-monitor"
"xmodef")))
(for-each sf-class
'("comwin"
diff --git a/src/edwin/edwin.ldr b/src/edwin/edwin.ldr
index 49d3a1493..dd4f32fcf 100644
--- a/src/edwin/edwin.ldr
+++ b/src/edwin/edwin.ldr
@@ -268,6 +268,7 @@ USA.
(->environment '(EDWIN BOCHSER)))
|#
(load "notify" environment)
+ (load "world-monitor" environment)
(if (access *external-doc-strings?* environment)
(begin
(set! (access *external-doc-strings?* environment) false)
diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 60e77d33c..711d69f3e 100644
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -99,6 +99,7 @@ USA.
"outline" ; outline minor mode
"sort" ; sorting commands
"webster" ; access a Webster server
+ "world-monitor"
)
(parent ())
diff --git a/src/edwin/world-monitor.scm b/src/edwin/world-monitor.scm
new file mode 100644
index 000000000..dac34edad
--- /dev/null
+++ b/src/edwin/world-monitor.scm
@@ -0,0 +1,118 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
+ Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Create a *World* buffer containing the world report.
+
+(declare (usual-integrations))
+
+(define-command monitor-world
+ "Find or create a buffer named *World*, insert a world report into
+it, and spawn a thread to update it after every
+\\[world-monitor-sleep] seconds."
+ ()
+ (lambda ()
+ (let* ((buffer (find-or-create-buffer "*World*"))
+ (thread (buffer-get buffer 'WORLD-MONITOR #f)))
+ (if (not thread)
+ (start-world-monitor buffer))
+ (pop-up-buffer buffer #f))))
+
+(define-variable world-monitor-sleep
+ "Number of seconds the world monitor should sleep between reports."
+ 1.
+ (lambda (object)
+ (and (flo:flonum? object)
+ (flo:< .09 object))))
+
+(define (start-world-monitor buffer)
+ (set-buffer-major-mode! buffer (ref-mode-object read-only))
+ (let ((registration #f)
+ (report #f)
+ (thread-flags (list (cons (current-thread) "Edwin"))))
+
+ (define (new-report)
+ (with-output-to-string
+ (lambda () (world-report (current-output-port) thread-flags))))
+
+ (define (sleep)
+ (sleep-current-thread
+ (flo:round->exact
+ (flo:* 1000. (ref-variable world-monitor-sleep)))))
+
+ (let ((monitor
+ (create-thread editor-thread-root-continuation
+ (named-lambda (monitor-world)
+ (let loop ()
+ (sleep)
+ (if (buffer-alive? buffer)
+ (begin
+ (if registration
+ (begin
+ (set! report (new-report))
+ (inferior-thread-output! registration)))
+ (loop))
+ (begin
+ (if registration
+ (deregister-inferior-thread! registration))
+ (set! registration #f)
+ (exit-current-thread #t))))))))
+
+ (buffer-put! buffer 'WORLD-MONITOR monitor)
+ (update-world-monitor! buffer (new-report))
+ (set! registration
+ (register-inferior-thread!
+ monitor (named-lambda (world-monitor-output!)
+ (update-world-monitor! buffer report)))))))
+
+(define (update-world-monitor! buffer report)
+ (let ((saved-windows
+ (map (lambda (window)
+ (cons window
+ (cons (mark-temporary-copy (window-point window))
+ (window-start-mark window) ;already temporary
+ )))
+ (buffer-windows buffer)))
+ (saved-mark (let ((ring (buffer-mark-ring buffer)))
+ (if (ring-empty? ring)
+ #f
+ (mark-temporary-copy (ring-ref ring 0))))))
+ (with-read-only-defeated
+ buffer (lambda ()
+ (with-group-undo-disabled
+ (buffer-group buffer)
+ (lambda ()
+ (buffer-widen! buffer)
+ (region-delete! (buffer-region buffer))
+ (insert-string report (buffer-start buffer))
+ (buffer-not-modified! buffer)))))
+ (for-each (lambda (item)
+ (let ((window (car item))
+ (point (cadr item))
+ (start (cddr item)))
+ (set-window-point! window point)
+ (set-window-start-mark! window start 0)))
+ saved-windows)
+ (if saved-mark (set-buffer-mark! buffer saved-mark))))
\ No newline at end of file