From 3fa3df389de9631846f4a37faf474d7f20d93563 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 28 Jun 2007 20:04:20 +0000
Subject: [PATCH] made stick figures, fixed PR 8776

svn: r6754
---
 collects/drscheme/private/main.ss          |  12 +-
 collects/drscheme/private/stick-figures.ss | 244 +++++++++++++++++++++
 collects/drscheme/private/unit.ss          |  17 +-
 3 files changed, 263 insertions(+), 10 deletions(-)
 create mode 100644 collects/drscheme/private/stick-figures.ss

diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss
index 050142673e..48fedc6e4c 100644
--- a/collects/drscheme/private/main.ss
+++ b/collects/drscheme/private/main.ss
@@ -453,7 +453,10 @@
       
       ;; NOTE: drscheme-normal.ss sets current-command-line-arguments to
       ;; the list of files to open, after parsing out flags like -h
-      (let* ([files-to-open (reverse (vector->list (current-command-line-arguments)))]
+      (let* ([files-to-open 
+              (if (preferences:get 'drscheme:open-in-tabs)
+                  (vector->list (current-command-line-arguments))
+                  (reverse (vector->list (current-command-line-arguments))))]
              [normalized/filtered
               (let loop ([files files-to-open])
                 (cond
@@ -472,5 +475,8 @@
                            f
                            (λ () (drscheme:unit:open-drscheme-window f))))
 		   no-dups)])
-	(when (null? (filter (λ (x) x) frames))
-	  (make-basic))))
+        (when (null? (filter (λ (x) x) frames))
+          (make-basic))
+        (when (and (preferences:get 'drscheme:open-in-tabs)
+                   (not (null? no-dups)))
+          (handler:edit-file (car no-dups)))))
diff --git a/collects/drscheme/private/stick-figures.ss b/collects/drscheme/private/stick-figures.ss
new file mode 100644
index 0000000000..ba3bd67dcc
--- /dev/null
+++ b/collects/drscheme/private/stick-figures.ss
@@ -0,0 +1,244 @@
+(module stick-figures mzscheme
+  (require (lib "class.ss")
+           (lib "pretty.ss")
+           (lib "mred.ss" "mred"))
+  
+  (provide running-canvas%)
+  
+  (define head-size 40)
+  (define small-factor 1/5)
+  (define waiting-points
+    '((head 47 -4)
+      (neck 40 14)
+      (shoulders 38 29)
+      (left-elbow 6 65)
+      (right-elbow 63 66)
+      (left-hand 59 73)
+      (right-hand 58 18)
+      (waist 35 77)
+      (left-knee 19 125)
+      (right-knee 58 123)
+      (left-ankle 15 161)
+      (right-ankle 61 163)
+      (left-toe 0 161)
+      (right-toe 75 157)))
+  
+  (define running-points
+    '((head 101 18)
+      (neck 85 33)
+      (shoulders 76 44)
+      (left-elbow 32 42)
+      (right-elbow 86 67)
+      (left-hand 20 62)
+      (right-hand 119 53)
+      (waist 31 79)
+      (left-knee 27 124)
+      (right-knee 68 93)
+      (left-ankle -6 141)
+      (right-ankle 60 132)
+      (left-toe 0 152)
+      (right-toe 82 132)))
+  
+  (define running-canvas%
+    (class canvas%
+      (inherit get-dc refresh)
+      (define/public (set-running r?) 
+        (unless (eq? r? is-running?)
+          (set! is-running? r?)
+          (refresh)))
+      (define is-running? #f)
+      
+      (define-values (w h running-dx running-dy waiting-dx waiting-dy)
+        (let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)]
+                     [(max-rx max-ry) (get-max/min-x/y max running-points)]
+                     [(min-wx min-wy) (get-max/min-x/y min waiting-points)]
+                     [(max-wx max-wy) (get-max/min-x/y max waiting-points)])
+          (let* ([running-w (* small-factor (- max-rx min-rx))]
+                 [waiting-w (* small-factor (- max-wx min-wx))]
+                 [running-h (* small-factor (- max-ry min-ry))]
+                 [waiting-h (* small-factor (- max-wy min-wy))]
+                 [w (+ 3 (ceiling (max running-w waiting-w)))]
+                 [h (+ 3 (ceiling (max running-h waiting-h)))]
+                 [running-dx (- (/ w 2) (/ running-w 2))]
+                 [running-dy (- (/ h 2) (/ running-h 2))]
+                 [waiting-dx (- (/ w 2) (/ waiting-w 2))]
+                 [waiting-dy (- (/ h 2) (/ waiting-h 2))])
+            (values w h running-dx running-dy waiting-dx waiting-dy))))
+
+      (define/override (on-paint)
+        (let ([dc (get-dc)])
+          (if is-running?
+              (draw-callback dc small-factor #f running-points running-dx running-dy)
+              (draw-callback dc small-factor #f waiting-points waiting-dx waiting-dy))))
+      (super-new [stretchable-width #f]
+                 [stretchable-height #f]
+                 [style '(transparent)])
+      (inherit min-width min-height)
+      (min-width w)
+      (min-height h)))
+  
+  (define (test-running-canvas)
+    (let* ([f (new frame% [label ""])]
+           [c (new running-canvas% [parent f])])
+      (new button% [parent f]
+           [label "on"]
+           [callback
+            (λ (x y) (send c set-running #t))])
+      (new button% [parent f]
+           [label "off"]
+           [callback
+            (λ (x y) (send c set-running #f))])
+      (send f show #t)))
+  
+
+  (define (normalize points)
+    (let-values ([(min-x min-y) (get-max/min-x/y min points)])
+      (map (λ (x) (list (car x) 
+                        (+ (- (list-ref x 1) min-x))
+                        (+ (- (list-ref x 2) min-y))))
+           points)))
+  
+  (define (get-max/min-x/y choose points)
+    (values (choose (- (list-ref (assoc 'head points) 1) (/ head-size 2))
+                    (+ (list-ref (assoc 'head points) 1) (/ head-size 2))
+                    (apply choose (map (λ (x) (list-ref x 1)) points)))
+            (choose (- (list-ref (assoc 'head points) 2) (/ head-size 2))
+                    (+ (list-ref (assoc 'head points) 2) (/ head-size 2))
+                    (apply choose (map (λ (x) (list-ref x 2)) points)))))
+  
+  (define show-dots? #t)
+  (define (draw-callback dc factor dots? points dx dy)
+    (send dc set-smoothing 'aligned)
+    (let ([points (normalize points)])
+      (send dc set-pen "orange" 1 'solid)
+      (send dc set-brush "orange" 'solid)
+      (when (and dots? show-dots?)
+        (for-each
+         (λ (x) (send dc draw-ellipse
+                      (+ dx (- (list-ref x 1) 4))
+                      (+ dy (- (list-ref x 2) 4))
+                      9 9))
+         points))
+      (send dc set-pen "black" 2 'solid)
+      (send dc set-brush "black" 'transparent)
+      (draw-points points dc factor dx dy)
+      
+      (let* ([head (assoc 'head points)]
+             [hx (list-ref head 1)]
+             [hy (list-ref head 2)])
+        (send dc draw-ellipse 
+              (+ dx (* factor (- hx (/ head-size 2))))
+              (+ dy (* factor (- hy (/ head-size 2))))
+              (* factor head-size)
+              (* factor head-size)))))
+  
+  (define (draw-points points dc factor dx dy)
+    (connect 'neck 'shoulders points dc factor dx dy)
+    (connect 'shoulders 'left-elbow points dc factor dx dy)
+    (connect 'shoulders 'right-elbow points dc factor dx dy)
+    (connect 'left-elbow 'left-hand points dc factor dx dy)
+    (connect 'right-elbow 'right-hand points dc factor dx dy)
+    (connect 'shoulders 'waist points dc factor dx dy)
+    (connect 'waist 'left-knee points dc factor dx dy)
+    (connect 'waist 'right-knee points dc factor dx dy)
+    (connect 'left-knee 'left-ankle points dc factor dx dy)
+    (connect 'right-knee 'right-ankle points dc factor dx dy)
+    (connect 'left-ankle 'left-toe points dc factor dx dy)
+    (connect 'right-ankle 'right-toe points dc factor dx dy))
+  
+  (define (connect from to points dc factor dx dy)
+    (let ([from-p (assoc from points)]
+          [to-p (assoc to points)])
+      (when (and from-p to-p)
+        (send dc draw-line 
+              (+ dx (* factor (list-ref from-p 1)))
+              (+ dy (* factor (list-ref from-p 2)))
+              (+ dx (* factor (list-ref to-p 1)))
+              (+ dy (* factor (list-ref to-p 2)))))))
+  
+  ;; Use this thunk to edit the points.
+  ;; Click the 'show' button to print out the pionts and then
+  ;; copy and paste them back into this file.
+  (define (edit-points points)
+    (define c%
+      (class canvas%
+        (inherit get-client-size refresh get-dc)
+        (define clicked-point #f)
+        (define clicked-x 0)
+        (define clicked-y 0)
+        (define orig-x 0)
+        (define orig-y 0)
+        (define/override (on-paint)
+          (draw-callback (get-dc) 1 #t points 0 0))
+        (define/override (on-event evt)
+          (cond
+            [(send evt button-down? 'left)
+             (let-values ([(w h) (get-client-size)])
+               (let ([x (send evt get-x)]
+                     [y (send evt get-y)])
+                 (let ([point (find-point this x y)])
+                   (when point
+                     (set! clicked-x x)
+                     (set! clicked-y y)
+                     (set! clicked-point point)
+                     (let ([orig-point (assoc point points)])
+                       (set! orig-x (list-ref orig-point 1))
+                       (set! orig-y (list-ref orig-point 2)))))))]
+            [(and clicked-point (send evt moving?))
+             (set! points 
+                   (map (λ (x)
+                          (if (eq? (car x) clicked-point)
+                              (list (list-ref x 0)
+                                    (+ orig-x (- (send evt get-x) clicked-x))
+                                    (+ orig-y (- (send evt get-y) clicked-y)))
+                              x))
+                        points))
+             (refresh)
+             (send csmall refresh)]
+            [(send evt button-up? 'left)
+             (set! clicked-point #f)]))
+        (super-new)))
+    
+    (define (find-point c x y)
+      (let loop ([points (normalize points)])
+        (cond
+          [(null? points) #f]
+          [else (let ([point (car points)])
+                  (if (and (<= (- (list-ref point 1) 4)
+                               x
+                               (+ (list-ref point 1) 4))
+                           (<= (- (list-ref point 2) 4)
+                               y
+                               (+ (list-ref point 2) 4)))
+                      (car point)
+                      (loop (cdr points))))])))
+    
+    (define f (new frame% [label ""] [width 400] [height 400]))
+    (define cp (new horizontal-panel% [parent f]))
+    (define cbig (new c% [parent cp]))
+    (define csmall
+      (new canvas%
+           [parent cp]
+           [paint-callback (λ (c dc) 
+                             (draw-callback dc small-factor #f running-points 0 0)
+                             (draw-callback dc small-factor #f waiting-points 30 0)
+                             (draw-callback dc small-factor #f points 30 50)
+                             (draw-callback dc small-factor #f points 0 50))]))
+    (define bp (new horizontal-panel% [parent f] [stretchable-height #f]))
+    (new button%
+         [parent bp]
+         [label "Show"]
+         [callback
+          (λ (x y)
+            (pretty-print points))])
+    (new button%
+         [parent bp]
+         [label "Toggle dots"]
+         [callback
+          (λ (x y)
+            (set! show-dots? (not show-dots?))
+            (send cbig refresh))])
+    (send f show #t))
+  
+  #;(edit-points waiting-points)
+  #;(edit-points running-points))
diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss
index f9fd2c88c9..5ab6319542 100644
--- a/collects/drscheme/private/unit.ss
+++ b/collects/drscheme/private/unit.ss
@@ -24,6 +24,7 @@ module browser threading seems wrong.
            (lib "name-message.ss" "mrlib")
            (lib "bitmap-label.ss" "mrlib")
            
+           "stick-figures.ss"
            "drsig.ss"
            "auto-language.ss"
            
@@ -1112,7 +1113,11 @@ module browser threading seems wrong.
             (inner (void) clear-annotations)
             (send ints reset-highlighting))
           
-          (define/public (update-running b?) (send frame update-running b?))
+          (define running? #f)
+          (define/public-final (is-running?) running?)
+          (define/public (update-running b?) 
+            (set! running? b?)
+            (send frame update-running b?))
           
           (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab)))
           
@@ -1503,10 +1508,7 @@ module browser threading seems wrong.
           [define/override get-canvas% (λ () (drscheme:get/extend:get-definitions-canvas))]
           
           (define/public (update-running running?)
-            (send running-message set-label 
-                  (if running?
-                      (string-constant running)
-                      (string-constant not-running))))
+            (send running-canvas set-running running?))
           (define/public (ensure-defs-shown)
             (unless definitions-shown?
               (toggle-show/hide-definitions)
@@ -2145,6 +2147,7 @@ module browser threading seems wrong.
               
               (send definitions-text update-frame-filename)
               (send definitions-text set-delegate old-delegate)
+              (update-running (send current-tab is-running?))
               (on-tab-change old-tab current-tab)
               (end-container-sequence)))
           
@@ -3203,8 +3206,8 @@ module browser threading seems wrong.
           [define/public get-button-panel (λ () button-panel)]
           
           (inherit get-info-panel)
-          (define running-message
-            (make-object message% (string-constant not-running) (get-info-panel)))
+          (define running-canvas
+            (new running-canvas% [parent (get-info-panel)]))
 
           
           [define func-defs-canvas (new func-defs-canvas%