From fb206a23d5ede1381791fdf9a0a652b6e3eba21f Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Fri, 14 Aug 2009 23:15:29 +0000
Subject: [PATCH] added last-picture option to stop-when

svn: r15740
---
 collects/2htdp/batch-io.ss      |  8 +++++--
 collects/2htdp/private/world.ss | 37 +++++++++++++++++++--------------
 collects/2htdp/universe.ss      | 10 +++++++--
 3 files changed, 35 insertions(+), 20 deletions(-)

diff --git a/collects/2htdp/batch-io.ss b/collects/2htdp/batch-io.ss
index c1f5ee0f7e..ae57d4d45e 100644
--- a/collects/2htdp/batch-io.ss
+++ b/collects/2htdp/batch-io.ss
@@ -8,9 +8,11 @@
   (list->string
     (with-input-from-file f 
       (lambda ()
-	(let loop ()
+	(let loop ([accu '()])
 	  (define nxt (read-char))
-	  (if (eof-object? nxt) '() (cons nxt (loop))))))))
+	  (if (eof-object? nxt)
+	      (reverse (if (char=? (car accu) #\newline) (cdr accu) accu))
+	      (loop (cons nxt accu))))))))
  
 (define (write-file f str)
   (check-arg 'read-file (string? f) "string" "first" f)
@@ -20,6 +22,8 @@
       #:exists 'truncate)
     result))
 
+;; -----------------------------------------------------------------------------
+
 (provide 
  read-file ;; String -> String
  ;; read the file f (in current-directory) as a string
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 36fe66980b..e06b0f1839 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -49,6 +49,7 @@
    (clock-mixin
     (class* object% (start-stop<%>)
       (inspect #f)
+      
       (init-field
        world0            ;; World
        (name #f)         ;; (U #f Symbol)
@@ -62,8 +63,8 @@
        (on-receive #f)   ;; (U #f (World S-expression -> World))
        (on-draw #f)      ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
        (stop-when False) ;; World -> Boolean 
-       (record? #f)      ;; Boolean 
-       )
+       (record? #f))     ;; Boolean 
+      
       ;; -----------------------------------------------------------------------
       (field
        (world
@@ -106,18 +107,18 @@
         (parameterize ([current-custodian *rec*])
           ;; try to register with the server n times 
           (let try ([n TRIES])
-              (printf "trying to register with ~a ...\n" register)
-              (with-handlers ((tcp-eof? (lambda (x) (printf FMTcom register)))
-                              (exn:fail:network? 
-                               (lambda (x)
-                                 (if (= n 1) 
-                                     (printf FMTtry register TRIES)
-                                     (begin (sleep PAUSE) (try (- n 1)))))))
-                (define-values (in out) (tcp-connect register SQPORT))
-                (tcp-register in out name)
-                (printf "... successful registered and ready to receive\n")
-                (set! *out* out)
-                (thread (RECEIVE in))))))
+            (printf "trying to register with ~a ...\n" register)
+            (with-handlers ((tcp-eof? (lambda (x) (printf FMTcom register)))
+                            (exn:fail:network? 
+                             (lambda (x)
+                               (if (= n 1) 
+                                   (printf FMTtry register TRIES)
+                                   (begin (sleep PAUSE) (try (- n 1)))))))
+              (define-values (in out) (tcp-connect register SQPORT))
+              (tcp-register in out name)
+              (printf "... successful registered and ready to receive\n")
+              (set! *out* out)
+              (thread (RECEIVE in))))))
       
       (define/private (broadcast msg)
         (when *out* 
@@ -219,6 +220,9 @@
                  (unless changed-world?
                    (when draw (pdraw))
                    (when (pstop) 
+                     (when last-picture 
+                       (set! draw last-picture)
+                       (pdraw))
                      (callback-stop! 'name)
                      (enable-images-button)))
                  changed-world?))))))
@@ -244,7 +248,8 @@
       
       ;; -----------------------------------------------------------------------
       ;; stop-when 
-      (field [stop  stop-when])
+      (field [stop (if (procedure? stop-when) stop-when (first stop-when))]
+             [last-picture (if (pair? stop-when) (second stop-when) #f)])
       
       (define/private (pstop)
         (define result (stop (send world get)))
@@ -273,7 +278,7 @@
       ;; initialize the world and run 
       (super-new)
       (start!)
-      (when (stop-when (send world get)) (stop! (send world get)))))))
+      (when (stop (send world get)) (stop! (send world get)))))))
 
 ;; -----------------------------------------------------------------------------
 (define-runtime-path break-btn:path '(lib "icons/break.png"))
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index ba0f7e2e82..9e9180d384 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -103,7 +103,8 @@
 ;;      | (on-mouse Expr) 
 ;; -- on-mouse must specify a mouse event handler 
 ;;      | (stop-when Expr)
-;; -- stop-when must specify a boolean-valued function 
+;;      | (stop-when Expr Expr)
+;; -- stop-when must specify a predicate; it may specify a rendering function
 ;;      | (register Expr)
 ;; -- register must specify the internet address of a host (including LOCALHOST)
 ;;      | (name Expr)
@@ -124,7 +125,12 @@
   [on-mouse (function-with-arity 4)]
   [on-key (function-with-arity 2)]
   [on-receive (function-with-arity 2)]
-  [stop-when (function-with-arity 1)]
+  [stop-when (function-with-arity 
+              1
+              except
+              [(stop? last-picture)
+               #'(list (proc> 'stop-when (f2h stop?) 1)
+                       (proc> 'stop-when (f2h last-picture) 1))])]
   [register (lambda (tag)
               (lambda (p)
                 (syntax-case p ()