restore unmodified version

svn: r10336

original commit: b93d242aa57c100171db4248776899d75250a5e6

collects/drscheme/arrow.ss

@@ -0,0 +1,195 @@
+
+(module arrow mzscheme
+  (require mzlib/class
+           mzlib/list
+           mzlib/math
+	   mred)
+
+  (provide draw-arrow)
+
+  (define largest 16383)
+  (define smallest -16383)
+
+  (define arrow-head-angle (/ pi 8))
+  (define cos-arrow-head-angle (cos arrow-head-angle))
+  (define sin-arrow-head-angle (sin arrow-head-angle))
+
+  (define arrow-head-size 8)
+  (define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle))
+  (define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle))
+
+  (define arrow-root-radius 2.5)
+  (define arrow-root-diameter (* 2 arrow-root-radius))
+
+  ; If alpha is the angle between the x axis and the Start->End vector:
+  ;
+  ; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle)
+  ;      = end-x - arrow-head-size * cos(alpha - arrow-head-angle)
+  ;      = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle))
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha
+  ;
+  ; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle)
+  ;      = end-y - arrow-head-size * sin(alpha - arrow-head-angle)
+  ;      = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle))
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha
+  ;
+  ; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle)
+  ;      = end-x - arrow-head-size * cos(alpha + arrow-head-angle)
+  ;      = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle))
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha
+  ;      = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha
+  ;
+  ; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle)
+  ;      = end-y - arrow-head-size * sin(alpha + arrow-head-angle)
+  ;      = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle))
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha
+  ;      = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha
+
+  ; dc<%> real real real real real real -> void
+  ; draw one arrow
+  ; The reason of the "-0.5" in the definition of start-x and end-x in the let
+  ; right below is because, well, after numerous experiments done under carefully
+  ; controlled conditions by a team of independent experts, it was thought to
+  ; be The Right Thing for the arrows to be drawn correctly, maybe.
+  (define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
+    (let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
+          [uncropped-start-y (+ uncropped-pre-start-y dy)]
+          [uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
+          [uncropped-end-y (+ uncropped-pre-end-y dy)]
+          [old-smoothed (send dc get-smoothing)])
+      (let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
+                    [(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
+        (send dc set-smoothing 'aligned)
+        (send dc draw-line start-x start-y end-x end-y)
+        (when (and (< smallest start-x largest)
+                   (< smallest end-x largest))
+          (send dc draw-ellipse 
+                (- start-x arrow-root-radius) (- start-y arrow-root-radius)
+                arrow-root-diameter arrow-root-diameter))
+        (when (and (< smallest end-x largest)
+                   (< smallest end-y largest))
+          (unless (and (= start-x end-x) (= start-y end-y))
+            (let* ([offset-x (- end-x start-x)]
+                   [offset-y (- end-y start-y)]
+                   [arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))]
+                   [cos-alpha (/ offset-x arrow-length)]
+                   [sin-alpha (/ offset-y arrow-length)]
+                   [arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)]
+                   [arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)]
+                   [arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)]
+                   [arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)]
+                   ; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1
+                   [pt1 (make-object point% end-x end-y)]
+                   [pt2 (make-object point%
+                          (- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha)
+                          (+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))]
+                   [pt3 (make-object point%
+                          (+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha)
+                          (- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))])
+              (send dc draw-polygon (list pt1 pt2 pt3)))))
+        (send dc set-smoothing old-smoothed))))
+
+  ;; crop-to : number number number number -> (values number number)
+  ;; returns x,y if they are in the range defined by largest and smallest
+  ;; otherwise returns the coordinates on the line from x,y to ox,oy
+  ;; that are closest to x,y and are in the range specified by
+  ;; largest and smallest
+  (define (crop-to x y ox oy)
+    (cond
+      [(and (< smallest x largest) (< smallest y largest))
+       (values x y)]
+      [else
+       (let* ([xy-pr (cons x y)]
+              [left-i (find-intersection x y ox oy smallest smallest smallest largest)]
+              [top-i (find-intersection x y ox oy smallest smallest largest smallest)]
+              [right-i (find-intersection x y ox oy largest smallest largest largest)]
+              [bottom-i (find-intersection x y ox oy smallest largest largest largest)]
+              [d-top (and top-i (dist top-i xy-pr))]
+              [d-bottom (and bottom-i (dist bottom-i xy-pr))]
+              [d-left (and left-i (dist left-i xy-pr))]
+              [d-right (and right-i (dist right-i xy-pr))])
+         (cond
+           [(smallest? d-top d-bottom d-left d-right)
+            (values (car top-i) (cdr top-i))]
+           [(smallest? d-bottom d-top d-left d-right)
+            (values (car bottom-i) (cdr bottom-i))]
+           [(smallest? d-left d-top d-bottom d-right)
+            (values (car left-i) (cdr left-i))]
+           [(smallest? d-right d-top d-bottom d-left)
+            (values (car right-i) (cdr right-i))]
+           [else 
+            ;; uh oh... if this case happens, that's bad news...
+            (values x y)]))]))
+
+  ;; smallest? : (union #f number)^4 -> boolean
+  ;; returns #t if can is less and o1, o2, and o3
+  ;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them
+  (define (smallest? can o1 o2 o3)
+    (and can
+         (andmap (λ (x) (< can x))
+                 (filter (λ (x) x)
+                         (list o1 o2 o3)))))
+
+
+  ;; inside? : (union #f (cons number number)) -> (union #f (cons number number))
+  ;; returns the original pair if the coordinates are between smallest and largest
+  ;; and returns #f if the pair is #f or the coordinates are outside.
+  (define (inside? pr)
+    (and pr
+         (let ([x (car pr)]
+               [y (cdr pr)])
+           (if (and (< smallest x largest)
+                    (< smallest y largest))
+               pr
+               #f))))
+
+  ;; find-intersection : (number^2)^2 -> (union (cons number number) #f)
+  ;; finds the intersection between the lines specified by
+  ;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4)
+  (define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
+    (cond
+      [(and (= x1 x2) (= x3 x4))
+       #f]
+      [(and (= x1 x2) (not (= x3 x4)))
+       (let* ([m2 (/ (- y3 y4) (- x3 x4))]
+              [b2 (- y3 (* m2 x3))])
+         (cons x1
+               (+ (* m2 x1) b2)))]
+      [(and (not (= x1 x2)) (= x3 x4))
+       (let* ([m1 (/ (- y1 y2) (- x1 x2))]
+              [b1 (- y1 (* m1 x1))])
+         (cons x3
+               (+ (* m1 x3) b1)))]
+      [(and (not (= x1 x2)) (not (= x3 x4)))
+       (let* ([m1 (/ (- y1 y2) (- x1 x2))]
+              [b1 (- y1 (* m1 x1))]
+              [m2 (/ (- y3 y4) (- x3 x4))]
+              [b2 (- y3 (* m2 x3))])
+         (if (= m1 m2)
+             #f
+             (let* ([x (/ (- b1 b2) (- m2 m1))]
+                    [y (+ (* m1 x) b1)])
+               (cons x y))))]))
+
+  ;; dist : (cons number number) (cons number number) -> number
+  (define (dist p1 p2)
+    (sqrt (+ (sqr (- (car p1) (car p2)))
+             (sqr (- (cdr p1) (cdr p2))))))
+
+  ;; localled defined test code.... :(
+  ;; use module language to run tests
+  (define (tests)
+    (and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f)
+         (equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0))
+         (equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0))
+         (equal? (find-intersection 0 0 3 3 2 2 4 4) #f)
+         (equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0))
+         (equal? (smallest? 3 1 2 3) #f)
+         (equal? (smallest? 0 1 2 3) #t)
+         (equal? (smallest? 1 0 2 3) #f)
+         (equal? (smallest? 1 0 #f 4) #f)
+         (equal? (smallest? 1 #f #f 4) #t)
+         (equal? (smallest? 1 #f #f #f) #t)
+         (equal? (dist (cons 1 1) (cons 4 5)) 5))))

collects/drscheme/default-code-style.ss

@@ -0,0 +1,27 @@
+(module default-code-style mzscheme
+  (provide color-default-code-styles
+           bw-default-code-styles
+           code-style-color
+           code-style-slant?
+           code-style-bold?
+           code-style-underline?)
+
+  (define-struct code-style (color slant? bold? underline?))
+  ;; code-style = (make-code-style (union (list number number number) string) bolean boolean)
+
+  ;; bw-default-code-styles : (listof (list symbol code-style
+  (define bw-default-code-styles
+    (list (list 'lexically-bound-variable (make-code-style "black" #f #f #t))
+          (list 'lexically-bound-syntax (make-code-style "black" #f #f #t))
+          (list 'imported-variable (make-code-style "black" #f #f #t))
+          (list 'imported-syntax (make-code-style "black" #f #f #t))
+          (list 'unbound-variable (make-code-style "black" #t #f #f))
+          (list 'constant (make-code-style '(51 135 39) #f #f #f))))
+
+  ;; color-default-code-styles : (listof (list symbol code-style))
+  (define color-default-code-styles
+    (list (list 'keyword (make-code-style '(40 25 15) #f #f #f))
+          (list 'unbound-variable (make-code-style "red" #f #f #f))
+          (list 'bound-variable (make-code-style "navy" #f #f #f))
+          (list 'primitive (make-code-style "navy" #f #f #f))
+          (list 'constant (make-code-style '(51 135 39) #f #f #f)))))

collects/drscheme/drscheme.creator

@@ -0,0 +1,2 @@
+DrSc
+(This code is registered with Apple.)

collects/drscheme/drscheme.filetypes

@@ -0,0 +1,20 @@
+((("CFBundleTypeName"
+   "Scheme Source")
+  ("CFBundleTypeIconFile"
+   "doc")
+  ("CFBundleTypeRole"
+   "Editor")
+  ("CFBundleTypeOSTypes"
+   (array "TEXT" "WXME"))
+  ("CFBundleTypeExtensions"
+   (array "scm" "ss")))
+ (("CFBundleTypeName"
+   "Package")
+  ("CFBundleTypeIconFile"
+   "pltdoc")
+  ("CFBundleTypeRole"
+   "Viewer")
+  ("CFBundleTypeOSTypes"
+   (array "PLT_" "WXME"))
+  ("CFBundleTypeExtensions"
+   (array "plt"))))

collects/drscheme/drscheme.ss

@@ -0,0 +1,47 @@
+(module drscheme mzscheme
+  (require "private/key.ss")
+
+  (define debugging? (getenv "PLTDRDEBUG"))
+
+  (define install-cm? (and (not debugging?)
+                           (getenv "PLTDRCM")))
+
+  (define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
+                        (equal? (getenv "PLTDRDEBUG") "trace")))
+
+  (when debugging?
+    (printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n")
+    (let-values ([(zo-compile
+                   make-compilation-manager-load/use-compiled-handler
+                   manager-trace-handler)
+                  (parameterize ([current-namespace (make-namespace)]
+                                 [use-compiled-file-paths '()])
+                    (values
+                     (dynamic-require '(lib "zo-compile.ss" "errortrace") 'zo-compile)
+                     (dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler)
+                     (dynamic-require 'mzlib/cm 'manager-trace-handler)))])
+      (current-compile zo-compile)
+      (use-compiled-file-paths (list (build-path "compiled" "errortrace")))
+      (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
+      (error-display-handler (dynamic-require '(lib "errortrace-lib.ss" "errortrace")
+                                              'errortrace-error-display-handler))
+      (when cm-trace?
+        (printf "PLTDRDEBUG: enabling CM tracing\n")
+        (manager-trace-handler
+         (λ (x) (display "1: ") (display x) (newline))))))
+
+  (when install-cm?
+    (printf "PLTDRCM: installing compilation manager\n")
+    (let-values ([(make-compilation-manager-load/use-compiled-handler
+                   manager-trace-handler)
+                  (parameterize ([current-namespace (make-namespace)])
+                    (values
+                     (dynamic-require 'mzlib/cm 'make-compilation-manager-load/use-compiled-handler)
+                     (dynamic-require 'mzlib/cm 'manager-trace-handler)))])
+      (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
+      (when cm-trace?
+        (printf "PLTDRCM: enabling CM tracing\n")
+        (manager-trace-handler
+         (λ (x) (display "1: ") (display x) (newline))))))
+
+  (dynamic-require 'drscheme/private/drscheme-normal #f))

collects/drscheme/drscheme.utiexports

@@ -0,0 +1,15 @@
+((("UTTypeConformsTo"
+   (array
+    "public.text"
+    "public.plain-text"))
+  ("UTTypeDescription"
+   "PLT Scheme program source")
+  ("UTTypeIdentifier"
+   "org.plt-scheme.source")
+  ("UTTypeTagSpecification"
+   (dict
+    (assoc-pair "com.apple.ostype"
+                "TEXT")
+    (assoc-pair "public.filename-extension"
+                (array "ss"
+                       "scm"))))))

collects/drscheme/info.ss

@@ -0,0 +1,6 @@
+#lang setup/infotab
+
+(define tools (list "syncheck.ss" (list "time-keystrokes.ss" "private")))
+(define tool-names (list "Check Syntax" "Time Keystrokes"))
+(define mred-launcher-names     (list "DrScheme"))
+(define mred-launcher-libraries (list "drscheme.ss"))

collects/drscheme/installer.ss

@@ -0,0 +1,21 @@
+(module installer mzscheme
+  (require mzlib/file
+           mzlib/etc
+           launcher)
+  (provide installer)
+
+  (define (installer plthome)
+    (do-installation)
+    (set! do-installation void))
+
+  (define (do-installation)
+    (for-each install-variation (available-mred-variants)))
+
+  (define (install-variation variant)
+    (parameterize ([current-launcher-variant variant])
+      (make-mred-launcher
+       (list "-ZmvqL" "drscheme.ss" "drscheme")
+       (mred-program-launcher-path "DrScheme")
+       (cons
+        `(exe-name . "DrScheme")
+        (build-aux-from-path (build-path (collection-path "drscheme") "drscheme")))))))