Merge branch 'master' of git.racket-lang.org:plt

collects/drracket/private/language-configuration.rkt

@@ -375,8 +375,9 @@
             (define/override (on-select i)
               (cond
                 [(and i (is-a? i hieritem-language<%>))
-                 (preferences:set 'drracket:language-dialog:hierlist-default (send (send i get-language) get-language-position))
+                 (define pos (send (send i get-language) get-language-position))
-                 (set! most-recent-languages-hier-list-selection i)
+                 (preferences:set 'drracket:language-dialog:hierlist-default pos)
+                 (set! most-recent-languages-hier-list-selection pos)
                  (something-selected i)]
                 [else
                  (non-language-selected)]))
@@ -430,8 +431,7 @@
                   (use-chosen-language-rb-callback))]))
         (define (use-chosen-language-rb-callback)
           (when most-recent-languages-hier-list-selection
-            (send languages-hier-list select 
+            (select-a-language-in-hierlist most-recent-languages-hier-list-selection))
-                  most-recent-languages-hier-list-selection))
           (send use-language-in-source-rb set-selection #f)
           (send languages-hier-list focus))
         (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel]))

collects/drracket/private/syncheck/gui.rkt

@@ -204,7 +204,7 @@ If the namespace does not, they are colored the unbound color.
     
     (define-struct graphic (pos* locs->thunks draw-fn click-fn))
     
-    (define-struct arrow (start-x start-y end-x end-y) #:mutable #:transparent)
+    (define-struct arrow () #:mutable #:transparent)
     (define-struct (var-arrow arrow)
       (start-text start-pos-left start-pos-right
                   end-text end-pos-left end-pos-right
@@ -420,12 +420,12 @@ If the namespace does not, they are colored the unbound color.
                    xr 
                    yr))))
             
-            (define/private (update-arrow-poss arrow)
+            (define/private (get-arrow-poss arrow)
               (cond
-                [(var-arrow? arrow) (update-var-arrow-poss arrow)]
+                [(var-arrow? arrow) (get-var-arrow-poss arrow)]
-                [(tail-arrow? arrow) (update-tail-arrow-poss arrow)]))
+                [(tail-arrow? arrow) (get-tail-arrow-poss arrow)]))
             
-            (define/private (update-var-arrow-poss arrow)
+            (define/private (get-var-arrow-poss arrow)
               (let-values ([(start-x start-y) (find-poss 
                                                (var-arrow-start-text arrow)
                                                (var-arrow-start-pos-left arrow)
@@ -434,12 +434,9 @@ If the namespace does not, they are colored the unbound color.
                                            (var-arrow-end-text arrow)
                                            (var-arrow-end-pos-left arrow)
                                            (var-arrow-end-pos-right arrow))])
-                (set-arrow-start-x! arrow start-x)
+                (values start-x start-y end-x end-y)))
-                (set-arrow-start-y! arrow start-y)
-                (set-arrow-end-x! arrow end-x)
-                (set-arrow-end-y! arrow end-y)))
             
-            (define/private (update-tail-arrow-poss arrow)
+            (define/private (get-tail-arrow-poss arrow)
               ;; If the item is an embedded editor snip, redirect
               ;; the arrow to point at the left edge rather than the
               ;; midpoint.
@@ -458,16 +455,14 @@ If the namespace does not, they are colored the unbound color.
                            [(end-x end-y) (find-poss/embedded
                                            (tail-arrow-to-text arrow)
                                            (tail-arrow-to-pos arrow))])
-                (set-arrow-start-x! arrow start-x)
+                (values start-x start-y end-x end-y)))
-                (set-arrow-start-y! arrow start-y)
+
-                (set-arrow-end-x! arrow end-x)
+            (define xlb (box 0))
-                (set-arrow-end-y! arrow end-y)))
+            (define ylb (box 0))
+            (define xrb (box 0))
+            (define yrb (box 0))
 
             (define/private (find-poss text left-pos right-pos)
-              (let ([xlb (box 0)]
-                    [ylb (box 0)]
-                    [xrb (box 0)]
-                    [yrb (box 0)])
               (send text position-location left-pos xlb ylb #t)
               (send text position-location right-pos xrb yrb #f)
               (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
@@ -475,7 +470,7 @@ If the namespace does not, they are colored the unbound color.
                             [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
                             [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
                 (values (/ (+ xl xr) 2)
-                          (/ (+ yl yr) 2)))))
+                        (/ (+ yl yr) 2))))
             
             ;; syncheck:init-arrows : -> void
             (define/public (syncheck:init-arrows)
@@ -701,8 +696,7 @@ If the namespace does not, they are colored the unbound color.
                 (when (add-to-bindings-table
                        start-text start-pos-left start-pos-right
                        end-text end-pos-left end-pos-right)
-                  (let ([arrow (make-var-arrow #f #f #f #f
+                  (let ([arrow (make-var-arrow start-text start-pos-left start-pos-right
-                                               start-text start-pos-left start-pos-right
                                                end-text end-pos-left end-pos-right
                                                actual? level)])
                     (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
@@ -711,7 +705,7 @@ If the namespace does not, they are colored the unbound color.
             ;; syncheck:add-tail-arrow : text number text number -> void
             (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos)
               (when arrow-records
-                (let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)])
+                (let ([tail-arrow (make-tail-arrow to-text to-pos from-text from-pos)])
                   (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
                   (add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))))
             
@@ -761,7 +755,6 @@ If the namespace does not, they are colored the unbound color.
             (define/augment (on-change)
               (inner (void) on-change)
               (when arrow-records
-                (flush-arrow-coordinates-cache)
                 (let ([any-tacked? #f])
                   (when tacked-hash-table
                     (let/ec k
@@ -773,18 +766,6 @@ If the namespace does not, they are colored the unbound color.
                   (when any-tacked?
                     (invalidate-bitmap-cache)))))
             
-            ;; flush-arrow-coordinates-cache : -> void
-            ;; pre-condition: arrow-records is not #f.
-            (define/private (flush-arrow-coordinates-cache)
-              (for ([(text arrow-record) (in-hash arrow-records)])
-                (for ([(start+end eles) (in-dict arrow-record)])
-                  (for ([ele (in-list eles)])
-                    (when (arrow? ele)
-                      (set-arrow-start-x! ele #f)
-                      (set-arrow-start-y! ele #f)
-                      (set-arrow-end-x! ele #f)
-                      (set-arrow-end-y! ele #f))))))
-            
             (define view-corner-hash (make-weak-hasheq))
             
             (define (get-last-view-corner admin)
@@ -835,12 +816,8 @@ If the namespace does not, they are colored the unbound color.
                     (start-arrow-draw-timer syncheck-arrow-delay)))
                 (let ([draw-arrow2
                        (λ (arrow)
-                         (unless (arrow-start-x arrow)
+                         (define-values (start-x start-y end-x end-y)
-                           (update-arrow-poss arrow))
+                           (get-arrow-poss arrow))
-                         (let ([start-x (arrow-start-x arrow)]
-                               [start-y (arrow-start-y arrow)]
-                               [end-x   (arrow-end-x arrow)]
-                               [end-y   (arrow-end-y arrow)])
                          (unless (and (= start-x end-x)
                                       (= start-y end-y))
                            (drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy
@@ -849,7 +826,7 @@ If the namespace does not, they are colored the unbound color.
                              (let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
                                (send dc draw-text "?"
                                      (+ end-x dx fw)
-                                       (+ end-y dy (- fh))))))))]
+                                     (+ end-y dy (- fh)))))))]
                       [old-brush (send dc get-brush)]
                       [old-pen   (send dc get-pen)]
                       [old-font  (send dc get-font)]
@@ -1014,11 +991,6 @@ If the namespace does not, they are colored the unbound color.
               (update-tooltip-frame)
               (update-docs-background cursor-eles)
               
-              (when cursor-eles
-                (for ([ele (in-list cursor-eles)])
-                  (when (arrow? ele)
-                    (update-arrow-poss ele))))
-              
               (invalidate-bitmap-cache))
             
             (define popup-menu #f)

collects/drracket/private/unit.rkt

@@ -1388,12 +1388,19 @@ module browser threading seems wrong.
       ;; so it stays alive as long 
       ;; as the frame stays alive
       (define show-line-numbers-pref-fn
-        (let ([fn (lambda (pref value) (show-line-numbers! value))])
+        (let ([fn (lambda (pref value)
+                    (when show-line-numbers-menu-item
+                      (send show-line-numbers-menu-item set-label
+                            (if value
+                                (string-constant hide-line-numbers/menu)
+                                (string-constant show-line-numbers/menu))))
+                    (show-line-numbers! value))])
           (preferences:add-callback
            'drracket:show-line-numbers?
            fn
            #t)
           fn))
+      (define show-line-numbers-menu-item #f)
       
       (define/override (add-line-number-menu-items menu)
         (define on? (preferences:get 'drracket:show-line-numbers?))
@@ -3978,6 +3985,7 @@ module browser threading seems wrong.
               has-editor-on-demand)
             (register-capability-menu-item 'drscheme:special:insert-lambda insert-menu))
           
+          (set! show-line-numbers-menu-item
                 (new menu:can-restore-menu-item%
                      [label (if (show-line-numbers?)
                                 (string-constant hide-line-numbers/menu)
@@ -3985,12 +3993,8 @@ module browser threading seems wrong.
                      [parent (get-show-menu)]
                      [callback (lambda (self event)
                                  (define value (preferences:get 'drracket:show-line-numbers?))
-                           (send self set-label
-                                 (if value
-                                     (string-constant show-line-numbers/menu)
-                                     (string-constant hide-line-numbers/menu)))
                                  (preferences:set 'drracket:show-line-numbers? (not value))
-                           (show-line-numbers! (not value)))])
+                                 (show-line-numbers! (not value)))]))
           
           (make-object separator-menu-item% (get-show-menu))
           

collects/meta/dist-specs.rkt

@@ -661,8 +661,6 @@ mz-extras :+= (- (package: "swindle")
 
 ;; -------------------- plot
 plt-extras :+= (package: "plot")
-               (src: "fit")
-               (lib: "libfit*")
 
 ;; -------------------- mzcom
 plt-extras :+= (- (package: "mzcom" #:src? #t)

collects/mred/private/wxme/keymap.rkt

@@ -445,7 +445,9 @@
   (def/public (handle-key-event [any? obj] [key-event% event])
     (let ([code (send event get-key-code)])
       (or (eq? code 'shift)
+          (eq? code 'rshift)
           (eq? code 'control)
+          (eq? code 'rcontrol)
           (eq? code 'release)
           (let ([score (get-best-score 
                         code

collects/mysterx/private/mxmain.rkt

@@ -1,9 +1,21 @@
-(module mxmain mzscheme
+#lang racket/base
 
-  ; dummy entries to make Setup happy
+(error "mxmain.rkt: you seem to be missing mxmain.dll; you need to build MysterX in plt\\src\\mysterx\\")
-  ; these are the names defined in mxPrims[] in src/mysterx.cxx
 
-  (provide
+(define-syntax provide-dummy
+  (syntax-rules ()
+    [(_ id) (begin
+            (provide id)
+            (define id (false/thwart-optimization)))]
+    [(_ id ...) (begin (provide-dummy id) ...)]))
+
+(define false/thwart-optimization #f)
+(set! false/thwart-optimization (lambda () #f))
+
+;; dummy entries to make Setup happy;
+;; these are the names defined in mxPrims[] in src/mysterx.cxx
+
+(provide-dummy
  mx-version
  block-while-browsers
  com-invoke
@@ -287,289 +299,3 @@
  release-type-table
  com-omit
  %%initialize-dotnet-runtime)
-
-  (error "mxmain.rkt: you seem to be missing mxmain.dll; you need to build MysterX in plt\\src\\mysterx\\")
-
-  (define mx-version #f)
-  (define block-while-browsers #f)
-  (define com-invoke #f)
-  (define com-set-property! #f)
-  (define com-get-property #f)
-  (define com-get-properties #f)
-  (define com-set-properties #f)
-  (define com-methods #f)
-  (define com-events #f)
-  (define com-method-type #f)
-  (define com-get-property-type #f)
-  (define com-set-property-type #f)
-  (define com-event-type #f)
-  (define com-help #f)
-  (define com-object-type #f)
-  (define com-is-a? #f)
-  (define com-currency? #f)
-  (define com-date? #f)
-  (define com-date->date #f)
-  (define date->com-date #f)
-  (define com-scode? #f)
-  (define com-scode->number #f)
-  (define number->com-scode #f)
-  (define com-currency->number #f)
-  (define number->com-currency #f)
-  (define com-object? #f)
-  (define com-iunknown? #f)
-  (define com-register-event-handler #f)
-  (define com-unregister-event-handler #f)
-  (define com-all-coclasses #f)
-  (define com-all-controls #f)
-  (define coclass->html #f)
-  (define progid->html #f)
-  (define cocreate-instance-from-coclass #f)
-  (define cocreate-instance-from-progid #f)
-  (define com-get-active-object-from-coclass #f)
-  (define coclass #f)
-  (define progid #f)
-  (define set-coclass! #f)
-  (define set-coclass-from-progid! #f)
-  (define com-object-eq? #f)
-  (define com-register-object #f)
-  (define com-release-object #f)
-  (define com-add-ref #f)
-  (define com-ref-count #f)
-  (define com-terminate #f)
-  (define make-browser #f)
-  (define browser-show #f)
-  (define navigate #f)
-  (define go-back #f)
-  (define go-forward #f)
-  (define refresh #f)
-  (define iconize #f)
-  (define restore #f)
-  (define current-url #f)
-  (define register-navigate-handler #f)
-  (define current-document #f)
-  (define print-document #f)
-  (define document? #f)
-  (define document-title #f)
-  (define document-insert-html #f)
-  (define document-append-html #f)
-  (define document-replace-html #f)
-  (define document-find-element #f)
-  (define document-find-element-by-id-or-name #f)
-  (define document-elements-with-tag #f)
-  (define document-objects #f)
-  (define element-insert-html #f)
-  (define element-append-html #f)
-  (define element-insert-text #f)
-  (define element-append-text #f)
-  (define element-replace-html #f)
-  (define element-get-html #f)
-  (define element-get-text #f)
-  (define element-focus #f)
-  (define element-selection #f)
-  (define element-set-selection! #f)
-  (define element-attribute #f)
-  (define element-set-attribute! #f)
-  (define element-click #f)
-  (define element-tag #f)
-  (define element-font-family #f)
-  (define element-set-font-family! #f)
-  (define element-font-style #f)
-  (define element-set-font-style! #f)
-  (define element-font-variant #f)
-  (define element-set-font-variant! #f)
-  (define element-font-weight #f)
-  (define element-set-font-weight! #f)
-  (define element-font #f)
-  (define element-set-font! #f)
-  (define element-background #f)
-  (define element-set-background! #f)
-  (define element-background-attachment #f)
-  (define element-set-background-attachment! #f)
-  (define element-background-image #f)
-  (define element-set-background-image! #f)
-  (define element-background-repeat #f)
-  (define element-set-background-repeat! #f)
-  (define element-background-position #f)
-  (define element-set-background-position! #f)
-  (define element-text-decoration #f)
-  (define element-set-text-decoration! #f)
-  (define element-text-transform #f)
-  (define element-set-text-transform! #f)
-  (define element-text-align #f)
-  (define element-set-text-align! #f)
-  (define element-margin #f)
-  (define element-set-margin! #f)
-  (define element-padding #f)
-  (define element-set-padding! #f)
-  (define element-border #f)
-  (define element-set-border! #f)
-  (define element-border-top #f)
-  (define element-set-border-top! #f)
-  (define element-border-bottom #f)
-  (define element-set-border-bottom! #f)
-  (define element-border-left #f)
-  (define element-set-border-left! #f)
-  (define element-border-right #f)
-  (define element-set-border-right! #f)
-  (define element-border-color #f)
-  (define element-set-border-color! #f)
-  (define element-border-width #f)
-  (define element-set-border-width! #f)
-  (define element-border-style #f)
-  (define element-set-border-style! #f)
-  (define element-border-top-style #f)
-  (define element-set-border-top-style! #f)
-  (define element-border-bottom-style #f)
-  (define element-set-border-bottom-style! #f)
-  (define element-border-left-style #f)
-  (define element-set-border-left-style! #f)
-  (define element-border-right-style #f)
-  (define element-set-border-right-style! #f)
-  (define element-style-float #f)
-  (define element-set-style-float! #f)
-  (define element-clear #f)
-  (define element-set-clear! #f)
-  (define element-display #f)
-  (define element-set-display! #f)
-  (define element-visibility #f)
-  (define element-set-visibility! #f)
-  (define element-list-style-type #f)
-  (define element-set-list-style-type! #f)
-  (define element-list-style-position #f)
-  (define element-set-list-style-position! #f)
-  (define element-list-style-image #f)
-  (define element-set-list-style-image! #f)
-  (define element-list-style #f)
-  (define element-set-list-style! #f)
-  (define element-position #f)
-  (define element-overflow #f)
-  (define element-set-overflow! #f)
-  (define element-pagebreak-before #f)
-  (define element-set-pagebreak-before! #f)
-  (define element-pagebreak-after #f)
-  (define element-set-pagebreak-after! #f)
-  (define element-css-text #f)
-  (define element-set-css-text! #f)
-  (define element-cursor #f)
-  (define element-set-cursor! #f)
-  (define element-clip #f)
-  (define element-set-clip! #f)
-  (define element-filter #f)
-  (define element-set-filter! #f)
-  (define element-style-string #f)
-  (define element-text-decoration-none #f)
-  (define element-set-text-decoration-none! #f)
-  (define element-text-decoration-underline #f)
-  (define element-set-text-decoration-underline! #f)
-  (define element-text-decoration-overline #f)
-  (define element-set-text-decoration-overline! #f)
-  (define element-text-decoration-linethrough #f)
-  (define element-set-text-decoration-linethrough! #f)
-  (define element-text-decoration-blink #f)
-  (define element-set-text-decoration-blink! #f)
-  (define element-pixel-top #f)
-  (define element-set-pixel-top! #f)
-  (define element-pixel-left #f)
-  (define element-set-pixel-left! #f)
-  (define element-pixel-width #f)
-  (define element-set-pixel-width! #f)
-  (define element-pixel-height #f)
-  (define element-set-pixel-height! #f)
-  (define element-pos-top #f)
-  (define element-set-pos-top! #f)
-  (define element-pos-left #f)
-  (define element-set-pos-left! #f)
-  (define element-pos-width #f)
-  (define element-set-pos-width! #f)
-  (define element-pos-height #f)
-  (define element-set-pos-height! #f)
-  (define element-font-size #f)
-  (define element-set-font-size! #f)
-  (define element-color #f)
-  (define element-set-color! #f)
-  (define element-background-color #f)
-  (define element-set-background-color! #f)
-  (define element-background-position-x #f)
-  (define element-set-background-position-x! #f)
-  (define element-background-position-y #f)
-  (define element-set-background-position-y! #f)
-  (define element-letter-spacing #f)
-  (define element-set-letter-spacing! #f)
-  (define element-vertical-align #f)
-  (define element-set-vertical-align! #f)
-  (define element-text-indent #f)
-  (define element-set-text-indent! #f)
-  (define element-line-height #f)
-  (define element-set-line-height! #f)
-  (define element-margin-top #f)
-  (define element-set-margin-top! #f)
-  (define element-margin-bottom #f)
-  (define element-set-margin-bottom! #f)
-  (define element-margin-left #f)
-  (define element-set-margin-left! #f)
-  (define element-margin-right #f)
-  (define element-set-margin-right! #f)
-  (define element-padding-top #f)
-  (define element-set-padding-top! #f)
-  (define element-padding-bottom #f)
-  (define element-set-padding-bottom! #f)
-  (define element-padding-left #f)
-  (define element-set-padding-left! #f)
-  (define element-padding-right #f)
-  (define element-set-padding-right! #f)
-  (define element-border-top-color #f)
-  (define element-set-border-top-color! #f)
-  (define element-border-bottom-color #f)
-  (define element-set-border-bottom-color! #f)
-  (define element-border-left-color #f)
-  (define element-set-border-left-color! #f)
-  (define element-border-right-color #f)
-  (define element-set-border-right-color! #f)
-  (define element-border-top-width #f)
-  (define element-set-border-top-width! #f)
-  (define element-border-bottom-width #f)
-  (define element-set-border-bottom-width! #f)
-  (define element-border-left-width #f)
-  (define element-set-border-left-width! #f)
-  (define element-border-right-width #f)
-  (define element-set-border-right-width! #f)
-  (define element-width #f)
-  (define element-set-width! #f)
-  (define element-height #f)
-  (define element-set-height! #f)
-  (define element-top #f)
-  (define element-set-top! #f)
-  (define element-left #f)
-  (define element-set-left! #f)
-  (define element-z-index #f)
-  (define element-set-z-index! #f)
-  (define event? #f)
-  (define get-event #f)
-  (define event-tag #f)
-  (define event-id #f)
-  (define event-from-tag #f)
-  (define event-from-id #f)
-  (define event-to-tag #f)
-  (define event-to-id #f)
-  (define event-keycode #f)
-  (define event-shiftkey #f)
-  (define event-ctrlkey #f)
-  (define event-altkey #f)
-  (define event-x #f)
-  (define event-y #f)
-  (define event-keypress? #f)
-  (define event-keydown? #f)
-  (define event-keyup? #f)
-  (define event-mousedown? #f)
-  (define event-mousemove? #f)
-  (define event-mouseover? #f)
-  (define event-mouseout? #f)
-  (define event-mouseup? #f)
-  (define event-click? #f)
-  (define event-dblclick? #f)
-  (define event-error? #f)
-  (define block-until-event #f)
-  (define process-win-events #f)
-  (define release-type-table #f)
-  (define com-omit #f)
-  (define %%initialize-dotnet-runtime #f))

collects/net/unihead.rkt

@@ -1,49 +1,77 @@
 #lang racket/base
-(require net/base64 net/qp racket/string)
+(require net/base64 net/qp)
 
 (provide encode-for-header decode-for-header generalize-encoding)
 
-(define re:ascii #rx"^[\u0-\u7F]*$")
+(define re:non-ascii #rx"[^\u0-\u7F]")
 
 (define (encode-for-header s)
-  (if (regexp-match? re:ascii s)
+  (cond [(not (regexp-match? re:non-ascii s)) s]
-    s
+        [(not (regexp-match? #rx"\r\n" s)) (encode-line-for-header s)] ; speed
-    (let ([l (regexp-split #rx"\r\n" s)])
+        [else (regexp-replace* #rx"[^\r\n]+" s encode-line-for-header)]))
-      (apply string-append
+
-             (map encode-line-for-header l)))))
+;; Note: the following two encoder wrappers remove newlines from the
+;; encoded strings.  This avoids producing invalid strings, but it's not
+;; complete: rfc2047 (section 2) specifies that encoded words should not
+;; be longer than 75 characters, and longer words should be split for
+;; encoding with a separator of CRLF SPACE between them.  The problem is
+;; that doing this properly requires changing the encoders to get a
+;; length limit and have them return also the leftover unencoded string.
+;; Instead of doing all of that, do something simpler: if the string to
+;; be encoded is longer than 70 characters, then split it.  (This is
+;; done in `encode-line-for-header' below.)  It's possible to get longer
+;; encodings with this, but it seems that sendmail's limit on line
+;; lengths is sufficiently larger that it works fine in practice.  (BTW,
+;; when sendmail gets lines that are too long it splits them with the
+;; dreaded "!\n ", and it looks like there is no sane way to avoid that
+;; behavior -- so splitting the input is needed.)
+
+(define (base64-encode-header s)
+  (regexp-replace* #rx#"[\r\n]+" (base64-encode s) #""))
+
+(define (qp-encode-header s)
+  ;; rfc2047 (section 4.2) calls this "Q encoding", which is different
+  ;; from the usual QP encoding: encode underlines and question marks,
+  ;; and replace spaces by underlines; also remove soft-newlines.
+  (regexp-replace* #rx#"[ ?_]"
+                   (regexp-replace* #rx#"=\r?\n" (qp-encode s) #"")
+                   (λ (b)
+                     (case (bytes-ref b 0)
+                       [(32) #"_"]   ; " "
+                       [(63) #"=3F"] ; "?"
+                       [(95) #"=5F"] ; "_"
+                       [else (error 'qp-encode-header "internal error")]))))
 
 (define (encode-line-for-header s)
-  (define (loop s string->bytes charset encode encoding)
+  (define (do-encode s string->bytes charset encode encoding)
-    ;; Find ASCII (and no "=") prefix before a space
+    (let loop ([s s])
-    (let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
-      (if m
-        (string-append
-         (cadr m)
-         (loop (caddr m) string->bytes charset encode encoding))
-        ;; Find ASCII (and no "=") suffix after a space
-        (let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
-          (if m
-            (string-append
-             (loop (cadr m) string->bytes charset encode encoding)
-             (caddr m))
-            (format "=?~a?~a?~a?="
-                    charset encoding
-                    (regexp-replace* #rx#"[\r\n]+$"
-                                     (encode (string->bytes s))
-                                     #"")))))))
       (cond
-    [(regexp-match? re:ascii s)
+        ;; Find ASCII (and no "=") prefix before a space
-     ;; ASCII - do nothing
+        [(regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)
-     s]
+         => (λ (m) (string-append (cadr m) (loop (caddr m))))]
-    [(regexp-match? #rx"[^\u0-\uFF]" s)
+        ;; Find ASCII (and no "=") suffix after a space
-     ;; Not Latin-1, so use UTF-8
+        [(regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)
-     (loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
+         => (λ (m) (string-append (loop (cadr m)) (caddr m)))]
         [else
+         ;; Split lines longer than 70 chars and re-assemble (see above
+         ;; comment).  Note that the proper separator should use CRLF,
+         ;; but we're sending this to a sendmail process that will take
+         ;; care of that level.
+         (let loop ([bytes (string->bytes s)])
+           (if ((bytes-length bytes) . > . 70)
+             (string-append (loop (subbytes bytes 0 70))
+                            "\n "
+                            (loop (subbytes bytes 70)))
+             (format "=?~a?~a?~a?=" charset encoding (encode bytes))))])))
+  (cond
+    ;; ASCII - do nothing
+    [(not (regexp-match? re:non-ascii s)) s]
+    ;; Not Latin-1, so use UTF-8
+    [(regexp-match? #rx"[^\u0-\uFF]" s)
+     (do-encode s string->bytes/utf-8 "UTF-8" base64-encode-header "B")]
     ;; use Latin-1
-     (loop s string->bytes/latin-1 "ISO-8859-1"
+    [else
-           (lambda (s)
+     (do-encode s string->bytes/latin-1 "ISO-8859-1" qp-encode-header "Q")]))
-             (regexp-replace #rx#" " (qp-encode s) #"_"))
-           "Q")]))
 
 ;; ----------------------------------------
 
@@ -68,8 +96,7 @@
          (if m
            (let ([s ((if (member (cadddr m) '(#"q" #"Q"))
                        ;; quoted-printable, with special _ handling
-                       (lambda (x)
+                       (λ (x) (qp-decode (regexp-replace* #rx#"_" x #" ")))
-                         (qp-decode (regexp-replace* #rx#"_" x #" ")))
                        ;; base64:
                        base64-decode)
                      (cadddr (cdr m)))]

collects/plot/compat.rkt

@@ -18,8 +18,6 @@
                                   plot-foreground plot-background
                                   plot3d-angle plot3d-altitude))
          "deprecated/renderers.rkt"
-         ;; Curve fitting
-         "deprecated/fit.rkt"
          ;; Miscellaneous
          "deprecated/math.rkt")
 
@@ -31,9 +29,6 @@
                                 contour shade
                                 surface)
          (only-doc-out (all-defined-out))
-         ;; Curve fitting
-         (rename-out [fit-int fit])
-         (struct-out fit-result)
          ;; Miscellaneous
          make-vec derivative gradient)
 

collects/plot/deprecated/fit-low-level.rkt

@@ -1,56 +0,0 @@
-(module fit-low-level racket/base
-  (require mzlib/foreign mzlib/runtime-path
-           (for-syntax racket/base))
-  (unsafe!)
-
-  (define-runtime-path libfit-path '(so "libfit"))
-
-  (define libfit (ffi-lib libfit-path))
-
-  (define do-fit-int
-    (get-ffi-obj "do_fit" libfit
-      (_fun (func      : (_fun _int _pointer -> _double))
-            (val-num   : _int = (length x-values))
-            (x-values  : (_list i _double*))
-            (y-values  : (_list i _double*))
-            (z-values  : (_list i _double*))
-            (errors    : (_list i _double*))
-            (param-num : _int = (length params))
-            (params    : (_list i _double*))
-            -> (_list o _double* param-num))))
-
-  (define (do-fit callback x-vals y-vals z-vals errors params)
-    (do-fit-int (lambda (argc argv)
-                  (let ([args (cblock->list argv _double argc)])
-                    (apply callback args)))
-                x-vals y-vals z-vals errors params))
-
-  (define get-asym-error
-    (get-ffi-obj "get_asym_error" libfit
-      (_fun (len : _?) ; len is only used for list conversion
-            -> (_list o _double* len))))
-
-  (define get-asym-error-percent
-    (get-ffi-obj "get_asym_error_percent" libfit
-      (_fun (len : _?) ; len is only used for list conversion
-            -> (_list o _double* len))))
-
-  (define get-rms
-    (get-ffi-obj "get_rms" libfit
-      (_fun -> _double*)))
-
-  (define get-varience
-    (get-ffi-obj "get_varience" libfit
-      (_fun -> _double*)))
-
-  (define (fit-internal f-of-x-y x-vals y-vals z-vals err-vals params)
-
-    (let* ([len (length params)]
-           [fit-result (do-fit f-of-x-y x-vals y-vals z-vals err-vals params)]
-           [asym-error (get-asym-error len)]
-           [asym-error-percent (get-asym-error-percent len)]
-           [rms (get-rms)]
-           [varience (get-varience)])
-      (list fit-result asym-error asym-error-percent rms varience)))
-
-  (provide fit-internal))

collects/plot/deprecated/fit.rkt

@@ -1,57 +0,0 @@
-(module fit mzscheme
-  (require unstable/lazy-require
-           "math.rkt")
-  
-  ;; Require lazily so the rest of 'plot' still works without libfit:
-  (lazy-require ["fit-low-level.rkt" (fit-internal)])
-
-  ; a structure contain a the results of a curve-fit
-  (define-struct fit-result (
-                             rms
-                             variance
-                             names
-                             final-params
-                             std-error
-                             std-error-percent
-                             function
-                             ) (make-inspector))
-
-  ; fit-int : (number* -> number) (list-of (symbol number)) (list-of (vector number [number] number number)) -> fit-result
-  (define (fit-int function guesses data)
-    (let* ((independent-vars (- (procedure-arity function) (length guesses)))
-           (f-of-x-y (cond
-                       [(= 1 independent-vars)
-                        (lambda (x y . rest)
-                          (apply function x rest))]
-                       [(= 2 independent-vars)
-                        function]
-                       [else
-                        (error "Function provided is either not of one or two independent variables or the number of
-                        guesses given is incorrect")]))
-           (x-vals (map vector-x data))
-           (y-vals (if (= 1 independent-vars)
-                       x-vals
-                        (map vector-y data)))
-           (z-vals (if (= 1 independent-vars)
-                       (map vector-y data)
-                       (map vector-z data)))
-           (err-vals (if (= 1 independent-vars)
-                         (map vector-z data)
-                         (map (lambda (vec) (vector-ref vec 4)) data)))
-           (result (fit-internal f-of-x-y x-vals y-vals z-vals err-vals (map cadr guesses))))
-      (if (null? result)
-          null
-          (begin
-            ;(display result)
-            (make-fit-result
-             (list-ref result 3)
-             (list-ref result 4)
-             (map car guesses)
-             (car result)
-             (cadr result)
-             (caddr result)
-             (lambda args (apply function(append args (car result)))))))))
-
-   (provide fit-int
-            (struct fit-result (rms variance names final-params
-                                std-error std-error-percent function))))

collects/plot/scribblings/compat.scrbl

@@ -127,116 +127,6 @@ Returns @racket[#t] if @racket[v] is one of the following symbols,
 
 @; ----------------------------------------
 
-@section[#:tag "curve-fit"]{Curve Fitting}
-
-@define[fit-warning]{
-@para{
-@bold{Do not use the @(racket fit) function. It is going to be removed in Racket 5.2.1.}
-It relies on old C code that nobody understands or is willing to maintain, and that is also slightly crashy.
-}}
-
-@fit-warning
-
-Quite independent of plotting, and for reasons lost in the sands of time,
-the @racketmodname[plot] library provides a non-linear, least-squares
-fit algorithm to fit parameterized functions to given data.
-The code that implements the algorithm is public
-domain, and is used by the @tt{gnuplot} package.
-
-To fit a particular function to a curve:
-
-@itemize[
-
-  @item{Set up the independent and dependent variable data.  The first
-  item in each vector is the independent variable, the second is the
-  result.  The last item is the weight of the error; we can leave it
-  as @racket[1] since all the items weigh the same.
-
-    @racketblock[
-      (define data '(#(0 3 1)
-                     #(1 5 1)
-                     #(2 7 1)
-                     #(3 9 1)
-                     #(4 11 1)))
-      ]
-    }
-
-  @item{Set up the function to be fitted using fit.  This particular
-  function looks like a line.  The independent variables must come
-  before the parameters.
-
-    @racketblock[
-      (define fit-fun
-        (lambda (x m b) (+ b (* m x))))
-      ]
-    }
-
-  @item{If possible, come up with some guesses for the values of the
-  parameters.  The guesses can be left as one, but each parameter must
-  be named.}
-
-  @item{Do the fit.
-
-    @racketblock[
-      (define fitted
-        (fit fit-fun
-             '((m 1) (b 1))
-             data))
-      ]
-    }
-
-  @item{View the resulting parameters; for example,
-
-    @racketblock[
-      (fit-result-final-params fitted)
-      ]
-
-    will produce @racketresultfont{(2.0 3.0)}.
-    }
-
-  @item{For some visual feedback of the fit result, plot the function
-    with the new parameters. For convenience, the structure that is
-    returned by the fit command has already the function.
-
-    @racketblock[
-      (plot (mix (points data)
-                 (line (fit-result-function fitted)))
-            #:y-max 15)
-      ]}]
-
-A more realistic example can be found in
-@filepath{compat/tests/fit-demo-2.rkt} in the @filepath{plot} collection.
-
-@defproc[(fit [f (real? ... . -> . real?)]
-              [guess-list (list/c (list symbol? real?))]
-              [data (or/c (list-of (vector/c real? real? real?))
-                          (list-of (vector/c real? real? real? real?)))])
-         fit-result?]{
-
-@fit-warning
-                       
-Attempts to fit a @defterm{fittable function} to the data that is
-given. The @racket[guess-list] should be a set of arguments and
-values. The more accurate your initial guesses are, the more likely
-the fit is to succeed; if there are no good values for the guesses,
-leave them as @racket[1].}
-
-@defstruct[fit-result ([rms real?]
-                       [variance real?]
-                       [names (listof symbol?)]
-                       [final-params (listof real?)]
-                       [std-error (listof real?)]
-                       [std-error-percent (listof real?)]
-                       [function (real? ... . -> . real?)])]{
-
-The @racket[params] field contains an associative list of the
-parameters specified in @racket[fit] and their values.  Note that the
-values may not be correct if the fit failed to converge.  For a visual
-test, use the @racket[function] field to get the function with the
-parameters in place and plot it along with the original data.}
-
-@; ----------------------------------------
-
 @section{Miscellaneous Functions}
 
 @defproc[(derivative [f (real? . -> . real?)] [h real? .000001])

collects/plot/scribblings/porting.scrbl

@@ -18,6 +18,8 @@ The update from PLoT version 5.1.3 to 5.2 introduces a few incompatibilities:
                 The argument change in @(racket plot3d) is similar.
                 This should not affect most code because PLoT encourages regarding these data types as black boxes.}
           @item{The @(racket plot-extend) module no longer exists.}
+          @item{The @racket[fit] function and @racket[fit-result] functions have been removed.}
+
           ]
 
 This section of the PLoT manual will help you port code written for PLoT 5.1.3 and earlier to the most recent PLoT.

collects/racket/draw/private/dc-path.rkt

@@ -7,12 +7,14 @@
          "fmod.rkt"
          "point.rkt"
          "transform.rkt"
+         "font.rkt"
          (only-in scheme/base 
                   [append s:append]
                   [reverse s:reverse]))
 
 (provide dc-path%
-         do-path)
+         (protect-out do-path
+                      set-text-to-path!))
 
 (define-local-member-name
   get-closed-points
@@ -22,6 +24,9 @@
 (define 2pi (* 2.0 pi))
 (define pi/2 (/ pi 2.0))
 
+(define text-to-path #f)
+(define (set-text-to-path! proc) (set! text-to-path proc))
+
 (define dc-path%
   (class object%
     ;; A path is a list of pairs and vectors:
@@ -277,6 +282,19 @@
       (do-arc x y w h 0 2pi #f)
       (close))
 
+    (def/public (text-outline [font% font] [string? str] [real? x] [real? y] [any? [combine? #f]])
+      (when (open?) (close))
+      (let ([p (text-to-path font str x y combine?)])
+        (for ([a (in-list p)])
+          (case (car a)
+            [(move) (move-to (cadr a) (caddr a))]
+            [(line) (line-to (cadr a) (caddr a))]
+            [(curve) (curve-to (cadr a) (caddr a)
+                               (list-ref a 3) (list-ref a 4)
+                               (list-ref a 5) (list-ref a 6))]
+            [(close) (close)])))
+      (close))
+
     (def/public (scale [real? x][real? y])
       (unless (and (= x 1.0) (= y 1.0))
         (flatten-open!)

collects/racket/draw/private/dc.rkt

@@ -32,7 +32,8 @@
 
 (define-local-member-name
   do-set-pen!
-  do-set-brush!)
+  do-set-brush!
+  text-path)
 
 (define 2pi (* 2 pi))
 
@@ -1161,9 +1162,16 @@
       (with-cr
        (check-ok 'draw-text)
        cr
-       (do-text cr #t s x y font combine? offset angle)
+       (do-text cr 'draw s x y font combine? offset angle)
        (flush-cr)))
 
+    (define/public (text-path s x y combine?)
+      (with-cr
+       (check-ok 'draw-text)
+       cr
+       (do-text cr 'path s x y font combine? 0 0.0)
+       (cairo_copy_path cr)))
+
     (define size-cache (make-weak-hasheq))
 
     (define/private (get-size-cache desc)
@@ -1231,12 +1239,12 @@
 	    (set-font-antialias c (dc-adjust-smoothing (send font get-smoothing)))
 	    c)))
 
-    (define/private (do-text cr draw? s x y font combine? offset angle)
+    (define/private (do-text cr draw-mode s x y font combine? offset angle)
       (let* ([s (if (zero? offset) 
                     s 
                     (substring s offset))]
              [blank? (string=? s "")]
-             [s (if (and (not draw?) blank?) " " s)]
+             [s (if (and (not draw-mode) blank?) " " s)]
              [s (if (for/or ([c (in-string s)])
                       (or (eqv? c #\uFFFE) (eqv? c #\uFFFF)))
                     ;; Since \uFFFE and \uFFFF are not supposed to be in any
@@ -1244,10 +1252,10 @@
                     ;; string to Pango:
                     (regexp-replace* #rx"[\uFFFE\uFFFF]" s "\uFFFD")
                     s)]
-             [rotate? (and draw? (not (zero? angle)))]
+             [rotate? (and draw-mode (not (zero? angle)))]
              [smoothing-index (get-smoothing-index)]
              [context (get-context cr smoothing-index)])
-        (when draw?
+        (when draw-mode
           (when (eq? text-mode 'solid)
             (unless rotate?
               (let-values ([(w h d a) (do-text cr #f s 0 0 font combine? 0 0.0)])
@@ -1276,7 +1284,7 @@
               ;; This is combine mode. It has to be a little complicated, after all,
               ;; because we may need to implement font substitution ourselves, which
               ;; breaks the string into multiple layouts.
-              (let loop ([s s] [draw? draw?] [measured? #f] [w 0.0] [h 0.0] [d 0.0] [a 0.0])
+              (let loop ([s s] [draw-mode draw-mode] [measured? #f] [w 0.0] [h 0.0] [d 0.0] [a 0.0])
                 (cond
                  [(not s)
                   (when rotate? (cairo_restore cr))
@@ -1313,11 +1321,11 @@
                                    (install-alternate-face (string-ref s 0) layout font desc attrs context))
                                  (substring s (max 1 ok-count))))])
                       (cond
-                       [(and draw? next-s (not measured?))
+                       [(and draw-mode next-s (not measured?))
                         ;; It's going to take multiple layouts, so first gather measurements.
                         (let-values ([(w2 h d a) (loop s #f #f w h d a)])
                           ;; draw again, supplying `h', `d', and `a' for the whole line
-                          (loop s #t #t w h d a))]
+                          (loop s draw-mode #t w h d a))]
                        [else
                         (let ([logical (make-PangoRectangle 0 0 0 0)])
                           (pango_layout_get_extents layout #f logical)
@@ -1325,16 +1333,19 @@
                                 [nd (/ (- (PangoRectangle-height logical)
                                           (pango_layout_get_baseline layout))
                                        (exact->inexact PANGO_SCALE))])
-                            (when draw?
+                            (when draw-mode
                               (let ([bl (if measured? (- h d) (- nh nd))])
                                 (pango_layout_get_extents layout #f logical)
                                 (cairo_move_to cr 
                                                (text-align-x/delta (+ x w) 0) 
                                                (text-align-y/delta (+ y bl) 0))
                                 ;; Draw the text:
-                                (pango_cairo_show_layout_line cr (pango_layout_get_line_readonly layout 0))))
+                                (let ([line (pango_layout_get_line_readonly layout 0)])
+                                  (if (eq? draw-mode 'draw)
+                                      (pango_cairo_show_layout_line cr line)
+                                      (pango_cairo_layout_line_path cr line)))))
                             (cond
-                             [(and draw? (not next-s))
+                             [(and draw-mode (not next-s))
                               (g_object_unref layout)
                               (when rotate? (cairo_restore cr))]
                              [else
@@ -1342,7 +1353,7 @@
                                             0.0
                                             (integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE))))]
                                     [na 0.0])
-                                (loop next-s measured? draw? (+ w nw) (max h nh) (max d nd) (max a na)))])))])))]))
+                                (loop next-s draw-mode measured? (+ w nw) (max h nh) (max d nd) (max a na)))])))])))]))
               ;; This is character-by-character mode. It uses a cached per-character+font layout
               ;;  object.
               (let ([cache (if (or combine?
@@ -1397,7 +1408,7 @@
                 ;; character or if we're just measuring text.
                 (begin0
                  (unless (and
-                          draw?
+                          (eq? draw-mode 'draw)
                           cache
                           (not attrs) ; fast path doesn't handle underline
                           ((string-length s) . > . 1)
@@ -1489,13 +1500,16 @@
                                                                         ;; unrounded height, for slow-path alignment
                                                                         flh)))
                                                    (values lw lh ld la flh)))))))])
-                         (when draw?
+                         (when draw-mode
                            (cairo_move_to cr 
                                           (text-align-x/delta (+ x w) 0) 
                                           (let ([bl (- flh ld)])
                                             (text-align-y/delta (+ y bl) 0)))
                            ;; Here's the draw command, which uses most of the time in this mode:
-                           (pango_cairo_show_layout_line cr (pango_layout_get_line_readonly layout 0)))
+                           (let ([line (pango_layout_get_line_readonly layout 0)])
+                             (if (eq? draw-mode 'draw)
+                                 (pango_cairo_show_layout_line cr line)
+                                 (pango_cairo_layout_line_path cr line))))
                          (values (if blank? 0.0 (+ w lw)) (max h lh) (max d ld) (max a la))))))
                  (when rotate? (cairo_restore cr))))))))
 
@@ -1819,3 +1833,14 @@
     (void))
 
   dc%)
+
+(set-text-to-path!
+ (lambda (font str x y combine?)
+   (define tmp-bm (make-object bitmap% 10 10))
+   (define tmp-dc (make-object -bitmap-dc% tmp-bm))
+   (send tmp-dc set-font font)
+   (define path (send tmp-dc text-path str x y combine?))
+   (begin0
+    (cairo-path->list path)
+    (cairo_path_destroy path))))
+

collects/racket/draw/private/record-dc.rkt

@@ -24,7 +24,9 @@
 (define black (send the-color-database find-color "black"))
 
 (define (clone-point p)
-  (make-object point% (point-x p) (point-y p)))
+  (if (pair? p)
+      p
+      (make-object point% (point-x p) (point-y p))))
 
 (define (clone-color c)
   (if (string? c)
@@ -101,6 +103,11 @@
   (class %
     (super-new)
 
+    (inherit get-origin get-scale get-rotation get-initial-matrix 
+             get-pen get-brush get-font
+             get-smoothing get-text-mode 
+             get-alpha get-clipping-region)
+
     (define record-limit +inf.0)
     (define current-size 0)
 
@@ -133,7 +140,30 @@
       (start-atomic)
       (set! procs null)
       (set! current-size 0)
-      (end-atomic))
+      (end-atomic)
+      ;; install current configuration explicitly (so it gets recorded):
+      (let-values ([(ox oy) (get-origin)]
+                   [(sx sy) (get-scale)]
+                   [(r) (get-rotation)]
+                   [(m) (get-initial-matrix)]
+                   [(p) (get-pen)]
+                   [(b) (get-brush)]
+                   [(s) (get-smoothing)]
+                   [(f) (get-font)]
+                   [(tm) (get-text-mode)]
+                   [(a) (get-alpha)]
+                   [(cr) (get-clipping-region)])
+        (unless (and (zero? ox) (zero? oy)) (set-origin ox oy))
+        (unless (and (= 1 sx) (= 1 sy)) (set-scale sx sy))
+        (unless (zero? r) (set-rotation r))
+        (unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m))
+        (do-set-pen! p)
+        (do-set-brush! b)
+        (set-font f)
+        (unless (eq? s 'unsmoothed) (set-smoothing s))
+        (unless (eq? tm 'transparent) (set-text-mode tm))
+        (unless (= a 1.0) (set-alpha a))
+        (when cr (set-clipping-region cr))))
 
     (define clones (make-hasheq))
     (define/private (clone clone-x x)

collects/racket/draw/unsafe/cairo.rkt

@@ -428,3 +428,59 @@
   CAIRO_FILTER_GAUSSIAN)
 
 (define/provide CAIRO_CONTENT_COLOR_ALPHA #x3000)
+
+;; ----------------------------------------
+
+(define-cstruct _cairo_path_data_t_header ([type _int]
+                                           [length _int]))
+(define-cstruct _cairo_path_data_t_point ([x _double]
+                                          [y _double]))
+
+(define _cairo_path_data_t (_union
+                            _cairo_path_data_t_header
+                            _cairo_path_data_t_point))
+
+(define-cstruct _cairo_path_t ([status _int]
+                               [data _pointer]
+                               [num_data _int]))
+
+(define-cairo cairo_path_destroy (_fun _cairo_path_t-pointer -> _void)
+  #:wrap (deallocator))
+
+(define-cairo cairo_copy_path (_fun _cairo_t -> _cairo_path_t-pointer)
+  #:wrap (allocator cairo_path_destroy))
+
+(define-enum 0
+  CAIRO_PATH_MOVE_TO
+  CAIRO_PATH_LINE_TO
+  CAIRO_PATH_CURVE_TO
+  CAIRO_PATH_CLOSE_PATH)
+
+(provide cairo-path->list)
+
+(define (cairo-path->list path)
+  (define len (cairo_path_t-num_data path))
+  (define data (cairo_path_t-data path))
+  (let loop ([i 0])
+    (if (= i len)
+        null
+        (let ([h (union-ref (ptr-ref data _cairo_path_data_t i) 0)])
+          (cons (let ([t (cairo_path_data_t_header-type h)])
+                  (cond
+                   [(or (= t CAIRO_PATH_MOVE_TO)
+                        (= t CAIRO_PATH_LINE_TO))
+                    (define a (union-ref (ptr-ref data _cairo_path_data_t (add1 i)) 1))
+                    (list (if (= t CAIRO_PATH_MOVE_TO) 'move 'line)
+                          (cairo_path_data_t_point-x a)
+                          (cairo_path_data_t_point-y a))]
+                   [(= t CAIRO_PATH_CURVE_TO)
+                    (define a (union-ref (ptr-ref data _cairo_path_data_t (+ 1 i)) 1))
+                    (define b (union-ref (ptr-ref data _cairo_path_data_t (+ 2 i)) 1))
+                    (define c (union-ref (ptr-ref data _cairo_path_data_t (+ 3 i)) 1))
+                    (list 'curve
+                          (cairo_path_data_t_point-x a) (cairo_path_data_t_point-y a)
+                          (cairo_path_data_t_point-x b) (cairo_path_data_t_point-y b)
+                          (cairo_path_data_t_point-x c) (cairo_path_data_t_point-y c))]
+                   [(= t CAIRO_PATH_CLOSE_PATH)
+                    '(close)]))
+                (loop (+ i (cairo_path_data_t_header-length h))))))))

collects/racket/draw/unsafe/pango.rkt

@@ -185,6 +185,7 @@
 (define-pangocairo pango_cairo_show_layout (_pfun _cairo_t PangoLayout -> _void))
 (define-pangocairo pango_cairo_show_layout_line (_pfun _cairo_t PangoLayoutLine -> _void))
 (define-pangocairo pango_cairo_show_glyph_string (_pfun _cairo_t PangoFont _PangoGlyphString-pointer -> _void))
+(define-pangocairo pango_cairo_layout_line_path (_pfun _cairo_t PangoLayoutLine -> _void))
 
 (define-pango pango_layout_iter_free (_pfun PangoLayoutIter -> _void)
   #:wrap (deallocator))

collects/scribble/text-render.rkt

@@ -99,12 +99,13 @@
                                       (if (eq? i 'cont)
                                           0
                                           (apply max d (map string-length i)))))
-                                  (apply map list strs))])
+                                  (apply map list strs))]
+                     [x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])
                 (for/fold ([indent? #f]) ([row (in-list strs)])
-                  (let ([h (apply max 0 (map length row))])
+                  (let ([h (apply max 0 (map x-length row))])
                     (let ([row* (for/list ([i (in-range h)])
                                   (for/list ([col (in-list row)])
-                                    (if (i . < . (length col))
+                                    (if (i . < . (x-length col))
                                         (list-ref col i)
                                         "")))])
                       (for/fold ([indent? indent?]) ([sub-row (in-list row*)])
@@ -116,7 +117,7 @@
                                          ""
                                          col)])
                             (display col)
-                            (display (make-string (- w (string-length col)) #\space)))
+                            (display (make-string (max 0 (- w (string-length col))) #\space)))
                           #t)
                         (newline)
                         #t)))

collects/scribblings/draw/dc-path-class.scrbl

@@ -264,6 +264,21 @@ If @racket[radius] is less than @racket[-0.5] or more than half of
 
 }
 
+@defmethod[(text-outline [font (is-a?/c font%)]
+                         [str string?]
+                         [x real?]
+                         [y real?]
+                         [combine? any/c #f])
+           void?]{
+
+Closes the @tech{open sub-path}, if any, and adds a @tech{closed
+ sub-path} to outline @racket[str] using @racket[font]. The
+ top left of the text is positioned at @racket[x] and @racket[y]. The
+ @racket[combine?] argument enables kerning and character combinations
+ as for @xmethod[dc<%> draw-text].
+
+}
+
 @defmethod[(translate [x real?]
                       [y real?])
            void?]{

collects/slideshow/tutorial-show.rkt

@@ -431,7 +431,7 @@
 (slide
  #:title "Arbitrary Drawing"
  (para "The" (code dc) "function provides an escape hatch to the underlying"
-            "GRacket toolkit")
+            (code racket/draw) "library")
  (para "For example," (code (disk 100)) "is the same as")
  (code
   (dc (lambda (dc dx dy)
@@ -878,4 +878,4 @@
   0.9)
  (blank)
  (para "For further information, search for"
-            (tt "slideshow") "in Help Desk"))
+            (tt "slideshow") "in the documentation"))

collects/tests/gracket/draw.rkt

@@ -65,11 +65,12 @@
     (send f show #t)))
 
 (define star
-  (list (make-object point% 30 0)
+  ;; uses pairs instead of point%s
-	(make-object point% 48 60)
+  (list (cons 30 0)
-	(make-object point% 0 20)
+	(cons 48 60)
-	(make-object point% 60 20)
+	(cons 0 20)
-	(make-object point% 12 60)))
+	(cons 60 20)
+	(cons 12 60)))
 
 (define octagon
   (list (make-object point% 60 60)
@@ -658,6 +659,17 @@
 					(loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h) #f)))))
 				(send dc set-pen save-pen)))
 
+                            ;; Text paths:
+                            (let ([p (make-object dc-path%)]
+                                  [old-pen (send dc get-pen)]
+                                  [old-brush (send dc get-brush)])
+                              (send p text-outline (make-font #:size 32) "A8" 360 190)
+                              (send dc set-pen "black" 1 'solid)
+                              (send dc set-brush "pink" 'solid)
+                              (send dc draw-path p)
+                              (send dc set-pen old-pen)
+                              (send dc set-brush old-brush))
+
 			    ; Bitmap copying:
 			    (when (and (not no-bitmaps?) last?)
 			      (let ([x 5] [y 165])
@@ -1079,6 +1091,11 @@
                                 [(lam) (let ([r (make-object region% clip-dc)])
                                          (send r set-path lambda-path)
                                          (send dc set-clipping-region r))]
+                                [(A) (let ([p (new dc-path%)]
+                                           [r (make-object region% clip-dc)])
+                                       (send p text-outline (make-font #:size 256) "A" 10 10)
+                                       (send r set-path p)
+                                       (send dc set-clipping-region r))]
                                 [(rect+poly) (let ([r (mk-poly 'winding)])
                                                (send r union (mk-rect))
                                                (send dc set-clipping-region r))]
@@ -1160,7 +1177,8 @@
 			      (let*-values ([(x y w h) (send r get-bounding-box)]
 					    [(l) (list x y w h)]
 					    [(=~) (lambda (x y)
-						    (<= (- x 2) y (+ x 2)))])
+						    (or (not y)
+                                                        (<= (- x 2) y (+ x 2))))])
 				(unless (andmap =~ l
 						(let ([l
 						       (case clip
@@ -1169,6 +1187,7 @@
 							 [(poly circle poly-rect) '(0. 60. 180. 180.)]
 							 [(wedge) '(26. 60. 128. 90.)]
 							 [(lam) '(58. 10. 202. 281.)]
+							 [(A) '(#f #f #f #f)]
 							 [(rect+poly rect+circle poly^rect) '(0. -25. 180. 400.)]
 							 [(poly&rect) '(100. 60. 10. 180.)]
 							 [(roundrect) '(80. 200. 125. 40.)]
@@ -1292,14 +1311,14 @@
 		   (send canvas set-kern (send self get-value))))
     (make-object choice% "Clip" 
 		 '("None" "Rectangle" "Rectangle2" "Octagon" 
-		   "Circle" "Wedge" "Round Rectangle" "Lambda"
+		   "Circle" "Wedge" "Round Rectangle" "Lambda" "A"
 		   "Rectangle + Octagon" "Rectangle + Circle" 
 		   "Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka"
 		   "Empty")
 		 hp3
 		 (lambda (self event)
 		   (set! clip (list-ref
-		               '(none rect rect2 poly circle wedge roundrect lam 
+		               '(none rect rect2 poly circle wedge roundrect lam A 
 				      rect+poly rect+circle poly-rect poly&rect poly^rect 
 				      polka empty)
 		               (send self get-selection)))

collects/tests/gracket/record-dc.rkt

@@ -0,0 +1,59 @@
+#lang racket/base
+(require racket/class
+         racket/draw
+         racket/draw/private/record-dc)
+
+(define bm1 (make-bitmap 100 100))
+(define bm2 (make-bitmap 100 100))
+(define bm3 (make-bitmap 100 100))
+
+(define dc1 (make-object bitmap-dc% bm1))
+(define dc2 (make-object (record-dc-mixin bitmap-dc%) bm2))
+(define dc3 (make-object bitmap-dc% bm3))
+
+(define (config dc)
+  (send dc set-origin 2 3)
+  (send dc set-scale 1.1 0.9)
+  (send dc set-rotation 0.1)
+  (send dc set-initial-matrix '#(1.0 -0.1 0.1 1.0 1.0 2.0))
+  (send dc set-pen "red" 2 'solid)
+  (send dc set-brush "blue" 'solid)
+  (send dc set-font (make-font #:size 32))
+  (send dc set-smoothing 'smoothed)
+  (send dc set-text-mode 'solid)
+  (send dc set-alpha 0.8)
+  (send dc set-clipping-rect 5 5 95 95))
+
+(define (draw dc)
+  (send dc draw-ellipse 2 2 100 100)
+  (send dc draw-text "Hello" 10 10))
+
+(define (get-bytes bm)
+  (define w (send bm get-width))
+  (define h (send bm get-height))
+  (define bstr (make-bytes (* 4 w h)))
+  (send bm get-argb-pixels 0 0 w h bstr)
+  bstr)
+
+(config dc1)
+(draw dc1)
+
+(define pre-bytes (get-bytes bm1))
+
+(config dc2)
+(send dc2 erase)
+(draw dc2)
+
+(define middle-bytes (get-bytes bm2))
+
+(define cms (send dc2 get-recorded-command))
+
+(cms dc3)
+
+(define post-bytes (get-bytes bm3))
+
+(unless (equal? pre-bytes middle-bytes)
+  (error "middle != pre"))
+
+(unless (equal? pre-bytes post-bytes)
+  (error "post != pre"))

doc/release-notes/racket/HISTORY.txt

@@ -1,5 +1,6 @@
 Version 5.2.0.7
 Intern strings, etc., only in read-syntax mode, not read mode
+racket/draw: add text-outline to dc-path%
 
 Version 5.2.0.6
 Added pseudo-random-generator-vector?

src/Makefile.in

@@ -39,28 +39,20 @@ all:
 3m:
 	cd racket; $(MAKE) 3m
 	$(MAKE) @MAKE_GRACKET@-3m
-	$(MAKE) @MAKE_FIT@-3m
 
 gracket-3m:
 	cd gracket; $(MAKE) 3m
 
-fit-3m:
-	cd fit; $(MAKE) 3m
-
 no-3m:
 	$(NOOP)
 
 cgc:
 	cd racket; $(MAKE) cgc
 	$(MAKE) @MAKE_GRACKET@-cgc
-	$(MAKE) @MAKE_FIT@-cgc
 
 gracket-cgc:
 	cd gracket; $(MAKE) cgc
 
-fit-cgc:
-	cd fit; $(MAKE) cgc
-
 no-cgc:
 	$(NOOP)
 
@@ -73,8 +65,7 @@ both:
 SETUP_ARGS = -X "$(DESTDIR)$(collectsdir)" -N "raco setup" -l- setup $(PLT_SETUP_OPTIONS) $(PLT_ISO) @INSTALL_SETUP_FLAGS@
 
 # Pass compile and link flags to `make install' for use by any
-#  collection-setup actions (currently in "plot") that compile
+#  collection-setup actions that compile and link C code:
-#  and link C code:
 CFLAGS = @CFLAGS@ @COMPFLAGS@ @PREFLAGS@
 LDFLAGS = @LDFLAGS@
 WITH_ENV_VARS = env CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" 
@@ -92,7 +83,6 @@ install-common-first:
 	mkdir -p $(ALLDIRINFO)
 
 install-common-middle:
-	$(MAKE) install-@MAKE_FIT@
 	$(MAKE) @MAKE_COPYTREE@-run
 	$(MAKE) install-@MAKE_GRACKET@-post-collects
 	$(MAKE) lib-finish
@@ -100,9 +90,6 @@ install-common-middle:
 install-common-last:
 	$(MAKE) fix-paths
 
-install-fit:
-	cd fit; $(MAKE) install
-
 install-no:
 	$(NOOP)
 

src/README

@@ -101,14 +101,14 @@ Detailed instructions:
     remove it (unless you are using an "in-place" build from a
     repository as described below).
 
-    Also, make sure that you have libraries and header files for
+    To run `racket/draw' and `racket/gui' programs, you will need
-    Cairo, Pango, and GTk.  These libraries are not distributed with
+    Cairo, Pango, and GTk install.  These libraries are not
-    Racket.  The configure process checks automatically whether these
+    distributed with Racket, and they are not needed for compilation,
-    libraries are available.
+    except for building documentation that uses `racket/draw'.
 
-    Finally, the content of the "foreign" subdirectory may require GNU
+    The content of the "foreign" subdirectory may require GNU `make'
-    `make'.  If the build fails with another variant of `make', please
+    if no installed "libffi" is detected.  If the build fails with
-    try using GNU `make'.
+    another variant of `make', please try using GNU `make'.
 
  1. Select (or create) a build directory.
 
@@ -175,13 +175,6 @@ Detailed instructions:
     which includes C compilation, and the Racket build normally uses
     the C pre-processor directly for some parts of the build.
 
-    For cross compilation, set the compiler variables to a compiler for
-    the target platform compiler, but also set CC_FOR_BUILD to a
-    compiler for the host platform (for building binaries to execute
-    during the build process).  If the target machine's stack grows up,
-    you'll have to supply `--enable-stackup'; if the target machine is
-    big-endian, you may have to supply `--enable-bigendian'.
-
     If you re-run `configure' after running `make', then products of the
     `make' may be incorrect due to changes in the compiler command line.
     To be safe, run `make clean' each time after running `configure'.
@@ -221,9 +214,10 @@ Detailed instructions:
     location originally specified with `--prefix'.
 
     Finally, the `make install' step compiles ".zo" bytecode files for
-    installed Racket source, and generates launcher programs like
+    installed Racket source, generates launcher programs like
-    DrRacket.  Use `make plain-install' to install without compiling
+    DrRacket, and builds documentation.  Use `make plain-install' to
-    ".zo" files or creating launchers.
+    install without compiling ".zo" files, creating launchers, or
+    building documentation.
 
     If the installation fails because the target directory cannot be
     created, or because the target directory is not the one you want,
@@ -265,6 +259,12 @@ Cross-compilation requires at least two flags to `configure':
 The `--enable-racket' flag is needed because building and installing
 Racket requires running (an intermediate version of) Racket.
 
+You may also need to set CC_FOR_BUILD to a compiler for the host
+platform (for building binaries to execute during the build process).
+If the target machine's stack grows up, you may have to supply
+`--enable-stackup'; if the target machine is big-endian, you may have
+to supply `--enable-bigendian'.
+
 ========================================================================
  CGC versus 3m
 ========================================================================
@@ -329,12 +329,12 @@ At a mininum, to port Racket to a new platform, edit "racket/sconfig.h"
 to provide a platform-specific compilation information.  As distributed,
 "racket/sconfig.h" contains configurations for the following platforms:
 
-              Windows (x86)
+              Windows (x86, x86_64)
               Mac OS X (PPC, x86, x86_64)
               Linux (x86, x86_64, PPC, 68k)
               Cygwin (x86)
               Solaris (x86, Sparc)
-              FreeBSD (x86)
+              FreeBSD (x86, x86_64)
               OpenBSD (x86)
               NetBSD (x86)
 
@@ -357,9 +357,8 @@ finalization is handled.
 Configuration Options
 ---------------------
 
-By default, Racket is compiled without support for single-precision
+Athough `configure' flags control most options, some configrations
-floating point numbers.  This and other options can be modified by
+options can be modified by setting flags in "racket/sconfig.h".
-setting flags in "racket/sconfig.h".
 
 Modifying Racket
 ----------------

src/configure

@@ -721,7 +721,6 @@ ICP
 MRLIBINSTALL
 LIBFINISH
 MAKE_GRACKET
-MAKE_FIT
 MAKE_COPYTREE
 MAKE_FINISH
 WXPRECOMP
@@ -1333,7 +1332,6 @@ Optional Features:
   --enable-foreign        support foreign calls (enabled by default)
   --enable-places         support places (3m only; usually enabled by default)
   --enable-futures        support futures (usually enabled by default)
-  --enable-plot           support plot libraries (enabled by default)
   --enable-float          support single-precision floats (enabled by default)
   --enable-floatinstead   use single-precision by default
   --enable-racket=<path>  use <path> as Racket executable to build Racket
@@ -1986,13 +1984,6 @@ if test "${enable_futures+set}" = set; then
   enableval=$enable_futures;
 fi
 
-# Check whether --enable-plot was given.
-if test "${enable_plot+set}" = set; then
-  enableval=$enable_plot;
-else
-  enable_plot=yes
-fi
-
 # Check whether --enable-float was given.
 if test "${enable_float+set}" = set; then
   enableval=$enable_float;
@@ -2314,7 +2305,6 @@ show_explicitly_enabled "${enable_xonx}" "Unix style"
 show_explicitly_enabled "${enable_shared}" "Shared libraries"
 
 show_explicitly_disabled "${enable_gracket}" GRacket
-show_explicitly_disabled "${enable_plot}" Plot fit library
 
 if test "$LIBTOOLPROG" != "" ; then
   echo "=== Libtool program: $LIBTOOLPROG"
@@ -8947,7 +8937,6 @@ LIBS="$LIBS $EXTRALIBS"
 
 
 
-
 
 
 mk_needed_dir()
@@ -9015,14 +9004,6 @@ fi
 makefiles="$makefiles foreign/Makefile"
 ac_configure_args="$ac_configure_args$SUB_CONFIGURE_EXTRAS"
 
-if test -d "${srcdir}/fit" && test "${enable_plot}" = "yes" ; then
-  makefiles="$makefiles
-             fit/Makefile"
-  MAKE_FIT=fit
-else
-  MAKE_FIT=no
-fi
-
 if test "${enable_gracket}" = "yes" ; then
   makefiles="$makefiles
              gracket/Makefile
@@ -9794,7 +9775,6 @@ ICP!$ICP$ac_delim
 MRLIBINSTALL!$MRLIBINSTALL$ac_delim
 LIBFINISH!$LIBFINISH$ac_delim
 MAKE_GRACKET!$MAKE_GRACKET$ac_delim
-MAKE_FIT!$MAKE_FIT$ac_delim
 MAKE_COPYTREE!$MAKE_COPYTREE$ac_delim
 MAKE_FINISH!$MAKE_FINISH$ac_delim
 WXPRECOMP!$WXPRECOMP$ac_delim
@@ -9832,7 +9812,7 @@ LIBOBJS!$LIBOBJS$ac_delim
 LTLIBOBJS!$LTLIBOBJS$ac_delim
 _ACEOF
 
-  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 46; then
+  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 45; then
     break
   elif $ac_last_try; then
     { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5

src/fit/Makefile.in

@@ -1,37 +0,0 @@
-
-srcdir = @srcdir@
-prefix = @prefix@
-exec_prefix = @exec_prefix@
-bindir = @bindir@
-libdir = @libdir@
-libpltdir = @libpltdir@
-collectsdir = @collectsdir@
-builddir = @builddir@
-
-ICP=@ICP@
-
-CC = @CC@
-
-# See ../Makefile about RUN_RACKET_<X>, which 
-# typically redirects to RUN_THIS_RACKET_<X>:
-RUN_THIS_RACKET_CGC = ../racket/racket@CGC@
-
-WITH_ENV = env CC="@PLAIN_CC@" CFLAGS="@CFLAGS@ @COMPFLAGS@ @PREFLAGS@" LDFLAGS="@LDFLAGS@"
-
-FIT_SRCS = $(srcdir)/fit.c $(srcdir)/matrix.c
-
-XCOLLECTS = # -X ../racket/gc2/xform-collects 
-
-fit-lib: libfit@SO_SUFFIX@
-
-3m:
-	$(MAKE) fit-lib
-cgc:
-	$(MAKE) fit-lib
-
-libfit@SO_SUFFIX@:
-	$(WITH_ENV) @RUN_RACKET_CGC@ -c $(srcdir)/build.rkt "libfit" $(FIT_SRCS)
-
-install:
-	cd ..; $(ICP) fit/libfit@SO_SUFFIX@ "$(DESTDIR)$(libpltdir)/libfit@SO_SUFFIX@"
-

src/fit/build.bat

@@ -1 +0,0 @@
-..\..\racket build.rkt libfit fit.c matrix.c

src/fit/build.rkt

@@ -1,32 +0,0 @@
-(module build racket/base
-  (require racket/path 
-           racket/file
-           dynext/file
-           dynext/link
-           dynext/compile)
-
-  (define-values (libname c-files)
-    (let ([l (vector->list (current-command-line-arguments))])
-      (values (car l)
-              (cdr l))))
-
-  (define sys-subpath (system-library-subpath #f))
-
-  (define so-name (append-extension-suffix libname))
-  (parameterize (;; we compile a simple .so, not an extension
-                 [current-standard-link-libraries '()])
-    (when (or (not (file-exists? so-name))
-              (let ([so-time (file-or-directory-modify-seconds so-name)])
-                (for/or ([f c-files])
-                  ((file-or-directory-modify-seconds f) . > . so-time))))
-      (let ([o-files
-             (for/list ([c-file c-files])
-               (let ([o-file (append-object-suffix (path-replace-suffix (file-name-from-path c-file) #""))])
-                 ;; first #f means not quiet (here and in link-extension)
-                 (compile-extension #f c-file o-file null)
-                 o-file))])
-        (let* ([flags (if (string=? "i386-cygwin" (path->string sys-subpath))
-                          ;; DLL needs every dependence explicit:
-                          '("-lc" "-lm" "-lcygwin" "-lkernel32")
-                          null)])
-          (link-extension #f (append o-files flags) so-name))))))

src/fit/dllexport.h

@@ -1,6 +0,0 @@
-
-#if (defined(__WIN32__) || defined(WIN32) || defined(_WIN32))
-# define MZ_DLLEXPORT __declspec(dllexport)
-#else
-# define MZ_DLLEXPORT
-#endif

src/fit/fit.c

@@ -1,752 +0,0 @@
-/*  NOTICE: Change of Copyright Status
- *
- *  The author of this module, Carsten Grammes, has expressed in
- *  personal email that he has no more interest in this code, and
- *  doesn't claim any copyright. He has agreed to put this module
- *  into the public domain.
- *
- *  Lars Hecking  15-02-1999
- */
-
-/*
- *    Nonlinear least squares fit according to the
- *      Marquardt-Levenberg-algorithm
- *
- *      added as Patch to Gnuplot (v3.2 and higher)
- *      by Carsten Grammes
- *      Experimental Physics, University of Saarbruecken, Germany
- *
- *      Internet address: cagr@rz.uni-sb.de
- *
- *      Copyright of this module:  1993, 1998  Carsten Grammes
- *
- *      Permission to use, copy, and distribute this software and its
- *      documentation for any purpose with or without fee is hereby granted,
- *      provided that the above copyright notice appear in all copies and
- *      that both that copyright notice and this permission notice appear
- *      in supporting documentation.
- *
- *      This software is provided "as is" without express or implied warranty.
- *
- *      930726:     Recoding of the Unix-like raw console I/O routines by:
- *                  Michele Marziani (marziani@ferrara.infn.it)
- * drd: start unitialised variables at 1 rather than NEARLY_ZERO
- *  (fit is more likely to converge if started from 1 than 1e-30 ?)
- *
- * HBB (Broeker@physik.rwth-aachen.de) : fit didn't calculate the errors
- * in the 'physically correct' (:-) way, if a third data column containing
- * the errors (or 'uncertainties') of the input data was given. I think
- * I've fixed that, but I'm not sure I really understood the M-L-algo well
- * enough to get it right. I deduced my change from the final steps of the
- * equivalent algorithm for the linear case, which is much easier to
- * understand. (I also made some minor, mostly cosmetic changes)
- *
- * HBB (again): added error checking for negative covar[i][i] values and
- * for too many parameters being specified.
- *
- * drd: allow 3d fitting. Data value is now called fit_z internally,
- * ie a 2d fit is z vs x, and a 3d fit is z vs x and y.
- *
- * Lars Hecking : review update command, for VMS in particular, where
- * it is not necessary to rename the old file.
- *
- * HBB, 971023: lifted fixed limit on number of datapoints, and number
- * of parameters.
- */
-
-
-#define FIT_MAIN
-
-#define NULL 0
-
-//#include <scheme.h>
-
-
-
-#include "matrix.h"
-#include "fit.h"
-#include <math.h>
-#include <stdlib.h>
-#include <string.h>
-
-/* #define STANDARD stderr */
-
-
-enum marq_res {
-    OK, ERROR, BETTER, WORSE
-};
-typedef enum marq_res marq_res_t;
-
-#ifdef INFINITY
-# undef INFINITY
-#endif
-
-#define INFINITY    1e30
-#define NEARLY_ZERO 1e-30
-
-
-/* Relative change for derivatives */
-#define DELTA	    0.001
-
-#define MAX_DATA    2048
-#define MAX_PARAMS  32
-#define MAX_LAMBDA  1e20
-#define MIN_LAMBDA  1e-20
-#define LAMBDA_UP_FACTOR 10
-#define LAMBDA_DOWN_FACTOR 10
-
-#define TBOOLEAN int
-
-# define PLUSMINUS   "+/-"
-
-
-
-/* HBB 971023: new, allow for dynamic adjustment of these: */
-static UNUSED int max_data;
-static UNUSED int max_params;
-
-static double epsilon = 1e-5;	/* convergence limit */
-static int maxiter = 0;		/* HBB 970304: maxiter patch */
-
-static UNUSED char *FIXED = "# FIXED";
-static UNUSED char *GNUFITLOG = "FIT_LOG";
-static UNUSED char *FITLIMIT = "FIT_LIMIT";
-static UNUSED char *FITSTARTLAMBDA = "FIT_START_LAMBDA";
-static UNUSED char *FITLAMBDAFACTOR = "FIT_LAMBDA_FACTOR";
-static UNUSED char *FITMAXITER = "FIT_MAXITER";	/* HBB 970304: maxiter patch */
-static UNUSED char *FITSCRIPT = "FIT_SCRIPT";
-static UNUSED char *DEFAULT_CMD = "replot";	/* if no fitscript spec. */
-
-
-static int num_data, num_params;
-static UNUSED int columns;
-static double  *fit_x;
-static double    *fit_y;
-static double  *fit_z ;
-static double   *err_data;
-static double *a;
-
-
-/* static fixstr * par_name; */
-
-static double startup_lambda = 0;
-static double lambda_down_factor = LAMBDA_DOWN_FACTOR;
-static double lambda_up_factor = LAMBDA_UP_FACTOR;
-
-
-static void * current_fun;
-
-
-/*****************************************************************
-			 internal vars to store results of fit
-*****************************************************************/
-
-double rms = 0;
-double varience = 0;
-double *asym_error;
-double *asym_error_percent;
-
-MZ_DLLEXPORT
-double get_rms()
-{return rms;}
-
-MZ_DLLEXPORT
-double get_varience()
-{return varience;}
-
-MZ_DLLEXPORT
-double * get_asym_error()
-{return asym_error;}
-
-MZ_DLLEXPORT
-double * get_asym_error_percent()
-{return asym_error_percent;}
-
-
-/*****************************************************************
-			 internal Prototypes
-*****************************************************************/
-
-/*static void printmatrix __PROTO((double **C, int m, int n)); */
-static UNUSED void print_matrix_and_vectors (double **C, double *d, double *r, int m, int n);
-static marq_res_t marquardt (double a[], double **alpha, double *chisq, 
-			     double *lambda); 
-static TBOOLEAN analyze (double a[], double **alpha, double beta[], 
-			 double *chisq);
-static void calculate (double *zfunc, double **dzda, double a[]);
-static void call_scheme (double *par, double *data);
-
-static TBOOLEAN regress (double a[]);
-//static void show_fit (int i, double chisq, double last_chisq, double *a, 
-//			      double lambda, FILE * device); 
-
-
-/*****************************************************************
-    New utility routine: print a matrix (for debugging the alg.)
-*****************************************************************/
-static UNUSED void printmatrix(C, m, n)
-double **C;
-int m, n;
-{
-    int i, j;
-
-    for (i = 0; i < m; i++) {
-	for (j = 0; j < n - 1; j++);
-	  /* Dblf2("%.8g |", C[i][j]); */
-	/* Dblf2("%.8g\n", C[i][j]); */
-    }
-    /* Dblf("\n"); */
-}
-
-/**************************************************************************
-    Yet another debugging aid: print matrix, with diff. and residue vector
-**************************************************************************/
-static UNUSED void print_matrix_and_vectors(C, d, r, m, n)
-double **C;
-double *d, *r;
-int m, n;
-{
-    int i, j;
-
-    for (i = 0; i < m; i++) {
-	for (j = 0; j < n; j++);
-	  /* Dblf2("%8g ", C[i][j]); */
-	  /* Dblf3("| %8g | %8g\n", d[i], r[i]); */
-    }
-    /* Dblf("\n"); */
-}
-
-
-/*****************************************************************
-    Marquardt's nonlinear least squares fit
-*****************************************************************/
-static marq_res_t marquardt(a, C, chisq, lambda)
-double a[];
-double **C;
-double *chisq;
-double *lambda;
-{
-    int i, j;
-    static double *da = 0,	/* delta-step of the parameter */
-    *temp_a = 0,		/* temptative new params set   */
-    *d = 0, *tmp_d = 0, **tmp_C = 0, *residues = 0;
-    double tmp_chisq;
-
-    /* Initialization when lambda == -1 */
-
-    if (*lambda == -1) {	/* Get first chi-square check */
-	TBOOLEAN analyze_ret;
-
-	temp_a = vec(num_params);
-	d = vec(num_data + num_params);
-	tmp_d = vec(num_data + num_params);
-	da = vec(num_params);
-	residues = vec(num_data + num_params);
-	tmp_C = matr(num_data + num_params, num_params);
-
-	analyze_ret = analyze(a, C, d, chisq);
-
-	/* Calculate a useful startup value for lambda, as given by Schwarz */
-	/* FIXME: this is doesn't turn out to be much better, really... */
-	if (startup_lambda != 0)
-	    *lambda = startup_lambda;
-	else {
-	    *lambda = 0;
-	    for (i = 0; i < num_data; i++)
-		for (j = 0; j < num_params; j++)
-		    *lambda += C[i][j] * C[i][j];
-	    *lambda = sqrt(*lambda / num_data / num_params);
-	}
-
-	/* Fill in the lower square part of C (the diagonal is filled in on
-	   each iteration, see below) */
-	for (i = 0; i < num_params; i++)
-	    for (j = 0; j < i; j++)
-		C[num_data + i][j] = 0, C[num_data + j][i] = 0;
-	/* printmatrix(C, num_data+num_params, num_params); */
-	return analyze_ret ? OK : ERROR;
-    }
-    /* once converged, free dynamic allocated vars */
-
-    if (*lambda == -2) {
-	return OK;
-    }
-    /* Givens calculates in-place, so make working copies of C and d */
-
-    for (j = 0; j < num_data + num_params; j++)
-	memcpy(tmp_C[j], C[j], num_params * sizeof(double));
-    memcpy(tmp_d, d, num_data * sizeof(double));
-
-    /* fill in additional parts of tmp_C, tmp_d */
-
-    for (i = 0; i < num_params; i++) {
-	/* fill in low diag. of tmp_C ... */
-	tmp_C[num_data + i][i] = *lambda;
-	/* ... and low part of tmp_d */
-	tmp_d[num_data + i] = 0;
-    }
-    /* printmatrix(tmp_C, num_data+num_params, num_params); */
-
-    /* FIXME: residues[] isn't used at all. Why? Should it be used? */
-
-    Givens(tmp_C, tmp_d, da, residues, num_params + num_data, num_params, 1);
-    /*print_matrix_and_vectors (tmp_C, tmp_d, residues,
-       num_params+num_data, num_params); */
-
-    /* check if trial did ameliorate sum of squares */
-
-    for (j = 0; j < num_params; j++)
-	temp_a[j] = a[j] + da[j];
-
-    if (!analyze(temp_a, tmp_C, tmp_d, &tmp_chisq)) {
-	/* FIXME: will never be reached: always returns TRUE */
-	return ERROR;
-    }
-
-    if (tmp_chisq < *chisq) {	/* Success, accept new solution */
-	if (*lambda > MIN_LAMBDA) {
-	  /* (void) putc('/', stderr); */
-          *lambda /= lambda_down_factor;
-	}
-	*chisq = tmp_chisq;
-	for (j = 0; j < num_data; j++) {
-	    memcpy(C[j], tmp_C[j], num_params * sizeof(double));
-	    d[j] = tmp_d[j];
-	}
-	for (j = 0; j < num_params; j++)
-	    a[j] = temp_a[j];
-	return BETTER;
-    } else {			/* failure, increase lambda and return */
-      /* (void) putc('*', stderr); */
-      *lambda *= lambda_up_factor;
-      return WORSE;
-    }
-}
-
-
-/* FIXME: in the new code, this function doesn't really do enough to be
- * useful. Maybe it ought to be deleted, i.e. integrated with
- * calculate() ?
- */
-/*****************************************************************
-    compute chi-square and numeric derivations
-*****************************************************************/
-static TBOOLEAN analyze(a, C, d, chisq)
-double a[];
-double **C;
-double d[];
-double *chisq;
-{
-/*
- *  used by marquardt to evaluate the linearized fitting matrix C
- *  and vector d, fills in only the top part of C and d
- *  I don't use a temporary array zfunc[] any more. Just use
- *  d[] instead.
- */
-    int i, j;
-
-    *chisq = 0;
-    calculate(d, C, a);
-
-    for (i = 0; i < num_data; i++) {
-	/* note: order reversed, as used by Schwarz */
-	d[i] = (d[i] - fit_z[i]) / err_data[i];
-	*chisq += d[i] * d[i];
-	for (j = 0; j < num_params; j++)
-	    C[i][j] /= err_data[i];
-    }
-    /* FIXME: why return a value that is always TRUE ? */
-    return 1;
-}
-
-
-/* To use the more exact, but slower two-side formula, activate the
-   following line: */
-
-#define TWO_SIDE_DIFFERENTIATION 
-
-/*****************************************************************
-    compute function values and partial derivatives of chi-square
-*****************************************************************/
-static void calculate(zfunc, dzda, a)
-double *zfunc;
-double **dzda;
-double a[];
-{
-    int k, p;
-    double tmp_a;
-    double *tmp_high, *tmp_pars;
-#ifdef TWO_SIDE_DIFFERENTIATION
-    double *tmp_low;
-#endif
-
-    tmp_high = vec(num_data);	/* numeric derivations */
-#ifdef TWO_SIDE_DIFFERENTIATION
-    tmp_low = vec(num_data);
-#endif
-    tmp_pars = vec(num_params);
-
-    /* first function values */
-
-    call_scheme(a, zfunc);
-
-    /* then derivatives */
-
-    for (p = 0; p < num_params; p++)
-	tmp_pars[p] = a[p];
-    for (p = 0; p < num_params; p++) {
-	tmp_a = fabs(a[p]) < NEARLY_ZERO ? NEARLY_ZERO : a[p];
-	tmp_pars[p] = tmp_a * (1 + DELTA);
-	call_scheme(tmp_pars, tmp_high);
-#ifdef TWO_SIDE_DIFFERENTIATION
-	tmp_pars[p] = tmp_a * (1 - DELTA);
-	call_scheme(tmp_pars, tmp_low);
-#endif
-	for (k = 0; k < num_data; k++)
-#ifdef TWO_SIDE_DIFFERENTIATION
-	    dzda[k][p] = (tmp_high[k] - tmp_low[k]) / (2 * tmp_a * DELTA);
-#else
-	    dzda[k][p] = (tmp_high[k] - zfunc[k]) / (tmp_a * DELTA);
-#endif
-	tmp_pars[p] = a[p];
-    }
-
-}
-
-
-/*****************************************************************
-    evaluate the scheme function
-*****************************************************************/
-static void call_scheme(par, data)
-double *par;
-double *data;
-{
-  int rators = 2 + num_params;
-  double * rands =
-    (double *) malloc(rators * sizeof(double));
-
-  int i;
-
-  /* set up the constant params */
-  for(i = 0 ; i< num_params; i++) {
-    rands[i+2] = par[i];
-  }
-
-  /* now calculate the function at the existing points */
-  for (i = 0; i < num_data; i++) {
-    rands[0] = fit_x[i];
-    rands[1] = fit_y[i];
-
-    data[i] = ((double (*) (int, double *) )current_fun) // ouch!
-               (rators, rands);
-  }
-
-  free(rands);
-
-}
-
-/* /\***************************************************************** */
-/*     evaluate the scheme function */
-/* *****************************************************************\/ */
-/* static void call_scheme(par, data) */
-/* double *par; */
-/* double *data; */
-/* { */
-/*   int rators = 2 + num_params; */
-/*   Scheme_Object ** rands =  */
-/*     scheme_malloc(rators * sizeof(Scheme_Object)); */
-
-/*   int i; */
-
-/*   /\* set up the constant params *\/ */
-/*   for(i = 0 ; i< num_params; i++) { */
-/*     rands[i+2] = scheme_make_double(par[i]); */
-/*   } */
-
-/*   /\* now calculate the function at the existing points *\/ */
-/*     for (i = 0; i < num_data; i++) { */
-/*       rands[0] = scheme_make_double(fit_x[i]); */
-/*       rands[1] = scheme_make_double(fit_y[i]); */
-
-/*       data[i] = scheme_real_to_double(scheme_apply(current_fun, rators, rands)); */
-/*     } */
-/* } */
-
-/*****************************************************************
-    Frame routine for the marquardt-fit
-*****************************************************************/
-static TBOOLEAN regress(a)
-    double a[];
-{
-  double **covar, *dpar, **C, chisq, last_chisq, lambda;
-  int iter, i, j;
-  marq_res_t res;
-  
-  chisq = last_chisq = INFINITY;
-  C = matr(num_data + num_params, num_params);
-  lambda = -1;          /* use sign as flag */
-  iter = 0;             /* iteration counter  */
-
-  /* Initialize internal variables and 1st chi-square check */
-
-  if ((res = marquardt(a, C, &chisq, &lambda)) == ERROR)
-    return 0; /* an error occurded */
-
-  res = BETTER;
-
-  /* show_fit(iter, chisq, chisq, a, lambda, STANDARD); */
-
-  /* MAIN FIT LOOP: do the regression iteration */
-
-  do {
-    if (res == BETTER) {
-      iter++;
-      last_chisq = chisq;
-    }
-    if ((res = marquardt(a, C, &chisq, &lambda)) == BETTER)
-      {};
-    /* show_fit(iter, chisq, last_chisq, a, lambda, STANDARD); */
-  } while ((res != ERROR)
-	   && (lambda < MAX_LAMBDA)
-	   && ((maxiter == 0) || (iter <= maxiter))
-	   && (res == WORSE
-	       || ((chisq > NEARLY_ZERO)
-		   ? ((last_chisq - chisq) / chisq)
-		   : (last_chisq - chisq)) > epsilon
-	       )
-	   );
-
-    /* fit done */
-
-  /* save all the info that was otherwise printed out */
-
-  rms = sqrt(chisq / (num_data - num_params));
-  varience = chisq / (num_data - num_params);
-  asym_error = malloc (num_params * sizeof (double));  
-  asym_error_percent = malloc (num_params * sizeof (double)) ;
-
-  /* don't know what the following code does... */
-
-  /* compute covar[][] directly from C */ 
-  Givens(C, 0, 0, 0, num_data, num_params, 0); 
-  covar = C + num_data; 
-  Invert_RtR(C, covar, num_params);
-  
-  dpar = vec(num_params); 
-  for (i = 0; i < num_params; i++) {
-    /* FIXME: can this still happen ? */
-      if (covar[i][i] <= 0.0)	/* HBB: prevent floating point exception later on */
-	return 0;  /* Eex("Calculation error: non-positive diagonal element in covar. matrix"); */
-    dpar[i] = sqrt(covar[i][i]);
-  }  
-
-  /* transform covariances into correlations */
-  for (i = 0; i < num_params; i++) {
-    /* only lower triangle needs to be handled */
-      for (j = 0; j <= i; j++)
-      covar[i][j] /= dpar[i] * dpar[j];
-  }
-
-  /* scale parameter errors based on chisq */
-  chisq = sqrt(chisq / (num_data - num_params));
-  for (i = 0; i < num_params; i++)
-    dpar[i] *= chisq;
-
-  for(i = 0; i< num_params; i++)
-    {
-      double temp = 
-	(fabs(a[i]) < NEARLY_ZERO) ? 0.0 : fabs(100.0 * dpar[i] / a[i]);
-      asym_error[i] = dpar[i];
-      asym_error_percent[i] = temp;
-    }
-
-  return 1;
-
-
-    /******** CRAP LEFT OVER FROM GNUPLOT ***********/
-
-    /* HBB 970304: the maxiter patch: */
-    /*
-    if ((maxiter > 0) && (iter > maxiter)) {
-	Dblf2("\nMaximum iteration count (%d) reached. Fit stopped.\n", maxiter);
-    } else  {
-	Dblf2("\nAfter %d iterations the fit converged.\n", iter);
-    }
-
-    Dblf2("final sum of squares of residuals : %g\n", chisq);
-    if (chisq > NEARLY_ZERO) {
-	Dblf2("rel. change during last iteration : %g\n\n", (chisq - last_chisq) / chisq);
-    } else {
-	Dblf2("abs. change during last iteration : %g\n\n", (chisq - last_chisq));
-    }
-
-    if (res == ERROR)
-      // Eex("FIT: error occurred during fit");
-    */
-    /* compute errors in the parameters */
-
-  /*   if (num_data == num_params) { */
-/* 	int i; */
-
-/* 	Dblf("\nExactly as many data points as there are parameters.\n"); */
-/* 	Dblf("In this degenerate case, all errors are zero by definition.\n\n"); */
-/* 	Dblf("Final set of parameters \n"); */
-/* 	Dblf("======================= \n\n"); */
-/* 	for (i = 0; i < num_params; i++) */
-/* 	    Dblf3("%-15.15s = %-15g\n", par_name[i], a[i]); */
-/*     } else if (chisq < NEARLY_ZERO) { */
-/* 	int i; */
-
-/* 	Dblf("\nHmmmm.... Sum of squared residuals is zero. Can't compute errors.\n\n"); */
-/* 	Dblf("Final set of parameters \n"); */
-/* 	Dblf("======================= \n\n"); */
-/* 	for (i = 0; i < num_params; i++) */
-/* 	    Dblf3("%-15.15s = %-15g\n", par_name[i], a[i]); */
-/*     } else { */
-/* 	Dblf2("degrees of freedom (ndf) : %d\n",  num_data - num_params); */
-/* 	Dblf2("rms of residuals      (stdfit) = sqrt(WSSR/ndf)      : %g\n", sqrt(chisq / (num_data - num_params))); */
-/*  	Dblf2("variance of residuals (reduced chisquare) = WSSR/ndf : %g\n\n", chisq / (num_data - num_params)); */
- 
-/* 	/\* get covariance-, Korrelations- and Kurvature-Matrix *\/ */
-/* 	/\* and errors in the parameters                     *\/ */
-
-/* 	/\* compute covar[][] directly from C *\/ */
-/* 	Givens(C, 0, 0, 0, num_data, num_params, 0); */
-/* 	/\*printmatrix(C, num_params, num_params); *\/ */
-
-/* 	/\* Use lower square of C for covar *\/ */
-/* 	covar = C + num_data; */
-/* 	Invert_RtR(C, covar, num_params); */
-/* 	/\*printmatrix(covar, num_params, num_params); *\/ */
-
-/* 	/\* calculate unscaled parameter errors in dpar[]: *\/ */
-/* 	dpar = vec(num_params); */
-/* 	for (i = 0; i < num_params; i++) { */
-/* 	    /\* FIXME: can this still happen ? *\/ */
-/* 	    if (covar[i][i] <= 0.0)	/\* HBB: prevent floating point exception later on *\/ */
-/* 		Eex("Calculation error: non-positive diagonal element in covar. matrix"); */
-/* 	    dpar[i] = sqrt(covar[i][i]); */
-/* 	} */
-
-/* 	/\* transform covariances into correlations *\/ */
-/* 	for (i = 0; i < num_params; i++) { */
-/* 	    /\* only lower triangle needs to be handled *\/ */
-/* 	    for (j = 0; j <= i; j++) */
-/* 		covar[i][j] /= dpar[i] * dpar[j]; */
-/* 	} */
-
-/* 	/\* scale parameter errors based on chisq *\/ */
-/* 	chisq = sqrt(chisq / (num_data - num_params)); */
-/* 	for (i = 0; i < num_params; i++) */
-/* 	    dpar[i] *= chisq; */
-
-/* 	Dblf("Final set of parameters            Asymptotic Standard Error\n"); */
-/* 	Dblf("=======================            ==========================\n\n"); */
-
-/* 	for (i = 0; i < num_params; i++) { */
-/* 	    double temp = */
-/* 	    (fabs(a[i]) < NEARLY_ZERO) ? 0.0 : fabs(100.0 * dpar[i] / a[i]); */
-/* 	    Dblf6("%-15.15s = %-15g  %-3.3s %-12.4g (%.4g%%)\n", */
-/* 		  par_name[i], a[i], PLUSMINUS, dpar[i], temp); */
-/* 	} */
-
-/* 	Dblf("\n\ncorrelation matrix of the fit parameters:\n\n"); */
-/* 	Dblf("               "); */
-
-/* 	for (j = 0; j < num_params; j++) */
-/* 	    Dblf2("%-6.6s ", par_name[j]); */
-
-/* 	Dblf("\n"); */
-/* 	for (i = 0; i < num_params; i++) { */
-/* 	    Dblf2("%-15.15s", par_name[i]); */
-/* 	    for (j = 0; j <= i; j++) { */
-/* 		/\* Only print lower triangle of symmetric matrix *\/ */
-/* 		Dblf2("%6.3f ", covar[i][j]); */
-/* 	    } */
-/* 	    Dblf("\n"); */
-/* 	} */
-
-/* 	free(dpar); */
-/*     } */
-
-    return 1;
-}
-
-
-/*****************************************************************
-    display actual state of the fit
-*****************************************************************/
-/* static void show_fit(i, chisq, last_chisq, a, lambda, device) */
-/* int i; */
-/* double chisq; */
-/* double last_chisq; */
-/* double *a; */
-/* double lambda; */
-/* FILE *device; */
-//{
-  /*
-    int k;
-
-    fprintf(device, "\n\n\
-Iteration %d\n\
-WSSR        : %-15g   delta(WSSR)/WSSR   : %g\n\
-delta(WSSR) : %-15g   limit for stopping : %g\n\
-lambda	  : %g\n\n%s parameter values\n\n",
-      i, chisq, chisq > NEARLY_ZERO ? (chisq - last_chisq) / chisq : 0.0,
-	    chisq - last_chisq, epsilon, lambda,
-	    (i > 0 ? "resultant" : "initial set of free"));
-    for (k = 0; k < num_params; k++)
-	fprintf(device, "%-15.15s = %g\n", par_name[k], a[k]);
-  */
-//}
-
-
-
-
-
-
-/*****************************************************************
-    Interface to scheme
-*****************************************************************/
-MZ_DLLEXPORT
-double * do_fit(void * function,
-		int n_values,
-		double * x_values,
-		double * y_values,
-		double * z_values,
-		double * errors,
-		int n_parameters,
-		double * parameters) {
-
-  /* reset lambda and other parameters if desired */
-  int i;
-  current_fun = function;
-
-  num_data = n_values;
-  fit_x = x_values;
-  fit_y = y_values;
-  fit_z = z_values; /* value is stored in z */
-  err_data = errors;
-
-  a = parameters;
-  num_params = n_parameters;
-
-  /* redim_vec(&a, num_params); */
-  /* par_name = (fixstr *) gp_realloc(par_name, (num_params + 1) * sizeof(fixstr), "fit param"); */
-
-  /* avoid parameters being equal to zero */
-  for (i = 0; i < num_params; i++) {
-    if (a[i] == 0) {
-      a[i] = NEARLY_ZERO; 
-    }
-  }
-  
-  if(regress(a)) {
-    gc_cleanup();
-    return a;
-  }
-  else { /* something went wrong */
-    gc_cleanup(); 
-    return NULL;
-  }
-}

src/fit/fit.h

@@ -1,62 +0,0 @@
-/* $Id: fit.h,v 1.5 2005/03/15 23:19:40 eli Exp $ */
-
-/* GNUPLOT - fit.h */
-
-/*  NOTICE: Change of Copyright Status
- *
- *  The author of this module, Carsten Grammes, has expressed in
- *  personal email that he has no more interest in this code, and
- *  doesn't claim any copyright. He has agreed to put this module
- *  into the public domain.
- *
- *  Lars Hecking  15-02-1999
- */
-
-/*
- *	Header file: public functions in fit.c
- *
- *
- *	Copyright of this module:   Carsten Grammes, 1993
- *      Experimental Physics, University of Saarbruecken, Germany
- *
- *	Internet address: cagr@rz.uni-sb.de
- *
- *	Permission to use, copy, and distribute this software and its
- *	documentation for any purpose with or without fee is hereby granted,
- *	provided that the above copyright notice appear in all copies and
- *	that both that copyright notice and this permission notice appear
- *	in supporting documentation.
- *
- *      This software is provided "as is" without express or implied warranty.
- */
-
-#include "dllexport.h"
-
-#ifdef __GNUC__
-# define UNUSED		__attribute__((unused))
-#else
-# define UNUSED
-#endif
-
-MZ_DLLEXPORT
-double * do_fit(void * function,
-		int n_values,
-		double * x_values,
-		double * y_values,
-		double * z_values,
-		double * errors,
-		int n_parameters,
-		double * parameters);
-
-
-MZ_DLLEXPORT
-double get_rms();
-
-MZ_DLLEXPORT
-double get_varience();
-
-MZ_DLLEXPORT
-double * get_asym_error();
-
-MZ_DLLEXPORT
-double * get_asym_error_percent();

src/fit/matrix.c

@@ -1,315 +0,0 @@
-/*  NOTICE: Change of Copyright Status
- *
- *  The author of this module, Carsten Grammes, has expressed in
- *  personal email that he has no more interest in this code, and
- *  doesn't claim any copyright. He has agreed to put this module
- *  into the public domain.
- *
- *  Lars Hecking  15-02-1999
- */
-
-/*
- *	Matrix algebra, part of
- *
- *	Nonlinear least squares fit according to the
- *	Marquardt-Levenberg-algorithm
- *
- *	added as Patch to Gnuplot (v3.2 and higher)
- *	by Carsten Grammes
- *	Experimental Physics, University of Saarbruecken, Germany
- *
- *	Internet address: cagr@rz.uni-sb.de
- *
- *	Copyright of this module:   Carsten Grammes, 1993
- *
- *	Permission to use, copy, and distribute this software and its
- *	documentation for any purpose with or without fee is hereby granted,
- *	provided that the above copyright notice appear in all copies and
- *	that both that copyright notice and this permission notice appear
- *	in supporting documentation.
- *
- *	This software is provided "as is" without express or implied warranty.
- */
-
-#define NULL 0
-#define null 0
-
-#include "fit.h"
-#include "matrix.h"
-#include <math.h>
-#include <stdlib.h>
-
-// create a simple gc malloc...
-typedef struct Node {
-  struct Node * next;
-  void * ptr;
-} Node;
-
-Node * head = null;
-
-void * my_gc_malloc(int size) {
-  void * ptr = malloc(size);
-  Node * n = (Node *)malloc(sizeof (Node));
-  n->ptr = ptr;
-  n->next = head;
-  head = n;
-  return ptr;
-}
-
-void gc_cleanup(){
-  while(head) {
-    Node * current = head;
-    head = current->next;
-    free(current->ptr);
-    free(current);
-  }
-}
-
-
-
-/*****************************************************************/
-
-#define Swap(a,b)   {double temp = (a); (a) = (b); (b) = temp;}
-#define WINZIG	      1e-30
-
-
-/*****************************************************************
-    internal prototypes
-*****************************************************************/
-
-static int fsign (double x);
-
-/*****************************************************************
-    first straightforward vector and matrix allocation functions
-*****************************************************************/
-MZ_DLLEXPORT
-double *vec (n)
-int n;
-{
-    /* allocates a double vector with n elements */
-    double *dp;
-    if( n < 1 )
-	return (double *) NULL;
-    dp = (double *) my_gc_malloc (n * sizeof(double));
-    return dp;
-}
-
-
-MZ_DLLEXPORT
-double **matr (rows, cols)
-int rows;
-int cols;
-{
-    /* allocates a double matrix */
-
-    register int i;
-    register double **m;
-
-    if ( rows < 1  ||  cols < 1 )
-        return NULL;
-    m = (double **) my_gc_malloc (rows * sizeof(double *));
-    m[0] = (double *) my_gc_malloc (rows * cols * sizeof(double));
-    for ( i = 1; i<rows ; i++ )
-    	m[i] = m[i-1] + cols;
-    return m;
-}
-
-
-void free_matr (m)
-double **m;
-{
-    free (m[0]);
-    free (m);
-}
-
-
-MZ_DLLEXPORT
-double *redim_vec (v, n)
-double **v;
-int n;
-{
-    if ( n < 1 ) 
-      *v = NULL;
-    else       
-      *v = (double *) my_gc_malloc( n * sizeof(double));
-    return *v;
-}
-
-MZ_DLLEXPORT
-void redim_ivec (v, n)
-int **v;
-int n;
-{
-    if ( n < 1 ) {
-	*v = NULL;
-	return;
-    }
-    *v = (int *) my_gc_malloc ( n * sizeof(int));
-}
-
-
-/* HBB: TODO: is there a better value for 'epsilon'? how to specify
- * 'inline'?  is 'fsign' really not available elsewhere? use
- * row-oriented version (p. 309) instead?
- */
-
-static int fsign(x)
-  double x;
-{
-    return( x>0 ? 1 : (x < 0) ? -1 : 0) ;
-}
-
-/*****************************************************************
-
-     Solve least squares Problem C*x+d = r, |r| = min!, by Given rotations
-     (QR-decomposition). Direct implementation of the algorithm
-     presented in H.R.Schwarz: Numerische Mathematik, 'equation'
-     number (7.33)
-
-     If 'd == NULL', d is not accesed: the routine just computes the QR
-     decomposition of C and exits.
-
-     If 'want_r == 0', r is not rotated back (\hat{r} is returned
-     instead).
-
-*****************************************************************/
-
-MZ_DLLEXPORT
-void Givens (C, d, x, r, N, n, want_r)
-double **C;
-double *d;
-double *x;
-double *r;
-int N;
-int n;
-int want_r;
-{
-    int i, j, k;
-    double w, gamma, sigma, rho, temp;
-    double epsilon = 1e-5; /* FIXME (?)*/
-
-/* 
- * First, construct QR decomposition of C, by 'rotating away'
- * all elements of C below the diagonal. The rotations are
- * stored in place as Givens coefficients rho.
- * Vector d is also rotated in this same turn, if it exists 
- */
-    for (j = 0; j<n; j++) 
-    	for (i = j+1; i<N; i++) 
-    	    if (C[i][j]) {
-    	    	if (fabs(C[j][j])<epsilon*fabs(C[i][j])) { /* find the rotation parameters */
-    	    	    w = -C[i][j];
-    	    	    gamma = 0;
-    	    	    sigma = 1;
-    	    	    rho = 1;
-		} else {
-		    w = fsign(C[j][j])*sqrt(C[j][j]*C[j][j] + C[i][j]*C[i][j]);
-		    if (w == 0) {
-		      //			Eex3 ( "w = 0 in Givens();  Cjj = %g,  Cij = %g", C[j][j], C[i][j]);
-		    }
-		    gamma = C[j][j]/w;
-		    sigma = -C[i][j]/w;
-		    rho = (fabs(sigma)<gamma) ? sigma : fsign(sigma)/gamma;
-		}
-		C[j][j] = w;
-		C[i][j] = rho;           /* store rho in place, for later use */
-		for (k = j+1; k<n; k++) {   /* rotation on index pair (i,j) */
-		    temp =    gamma*C[j][k] - sigma*C[i][k];
-		    C[i][k] = sigma*C[j][k] + gamma*C[i][k];
-		    C[j][k] = temp;
-		    
-		}
-		if (d) {               /* if no d vector given, don't use it */
-		    temp = gamma*d[j] - sigma*d[i];  /* rotate d */
-		    d[i] = sigma*d[j] + gamma*d[i];
-		    d[j] = temp;
-	        }
-	    }
-    if (!d)               /* stop here if no d was specified */
-         return;
-
-    for (i = n-1; i >= 0; i--) {   /* solve R*x+d = 0, by backsubstitution */
-        double s = d[i];
-        r[i] = 0;              /* ... and also set r[i] = 0 for i<n */
-        for (k = i+1; k<n; k++) 
-            s += C[i][k]*x[k];
-	if (C[i][i] == 0) {
-	  //Eex ( "Singular matrix in Givens()");
-	}
-        x[i] = - s / C[i][i];
-	}
-    for (i = n; i < N; i++) 
-    	r[i] = d[i];	     	/* set the other r[i] to d[i] */
-    	
-    if (!want_r)        	/* if r isn't needed, stop here */
-    	return;
-    	
-    /* rotate back the r vector */
-    for (j = n-1; j >= 0; j--)
-    	for (i = N-1; i >= 0; i--) {
-    	    if ((rho = C[i][j]) == 1) { /* reconstruct gamma, sigma from stored rho */
-    	     	gamma = 0;
-    	     	sigma = 1;
-    	    } else if (fabs(rho)<1) {
-    	    	sigma = rho; 
-    	    	gamma = sqrt(1-sigma*sigma);
-    	    } else {
-    	    	gamma = 1/fabs(rho);
-    	    	sigma = fsign(rho)*sqrt(1-gamma*gamma);
-    	    }
-	    temp = gamma*r[j] + sigma*r[i];	/* rotate back indices (i,j) */
-	    r[i] = -sigma*r[j] + gamma*r[i];
-	    r[j] = temp;
-    }
-}
-
-
-/* Given a triangular Matrix R, compute (R^T * R)^(-1), by forward
- * then back substitution
- * 
- * R, I are n x n Matrices, I is for the result. Both must already be
- * allocated.
- * 
- * Will only calculate the lower triangle of I, as it is symmetric 
- */
-
-MZ_DLLEXPORT
-void Invert_RtR ( R, I, n)
-double **R;
-double **I;
-int n;
-{
-  int i, j, k;
-
-  /* fill in the I matrix, and check R for regularity : */
-
-  for (i = 0; i<n; i++) {
-    for (j = 0; j<i; j++)  /* upper triangle isn't needed */
-      I[i][j] = 0;
-    I[i][i] = 1;
-    if (! R[i][i])
-      {
-      //      Eex ("Singular matrix in Invert_RtR");
-      }
-      }
-  
-  /* Forward substitution: Solve R^T * B = I, store B in place of I */
-  
-  for (k = 0; k<n; k++) 
-    for (i = k; i<n; i++) {  /* upper half needn't be computed */
-      double s = I[i][k];
-      for (j = k; j<i; j++)  /* for j<k, I[j][k] always stays zero! */
-	s -= R[j][i] * I[j][k];
-      I[i][k] = s / R[i][i];
-    }
-
-  /* Backward substitution: Solve R * A = B, store A in place of B */
-
-  for (k = 0; k<n; k++)
-    for (i = n-1; i >= k; i--) {  /* don't compute upper triangle of A */
-      double s = I[i][k];
-      for (j = i+1; j<n; j++)
-	s -= R[i][j] * I[j][k];
-      I[i][k] = s / R[i][i]; 
-    }
-}

src/fit/matrix.h

@@ -1,75 +0,0 @@
-/* $Id: matrix.h,v 1.5 2005/03/15 23:23:56 eli Exp $ */
-
-/* GNUPLOT - matrix.h */
-
-/*  NOTICE: Change of Copyright Status
- *
- *  The author of this module, Carsten Grammes, has expressed in
- *  personal email that he has no more interest in this code, and
- *  doesn't claim any copyright. He has agreed to put this module
- *  into the public domain.
- *
- *  Lars Hecking  15-02-1999
- */
-
-/*
- *	Header file: public functions in matrix.c
- *
- *
- *	Copyright of this module:   Carsten Grammes, 1993
- *      Experimental Physics, University of Saarbruecken, Germany
- *
- *	Internet address: cagr@rz.uni-sb.de
- *
- *	Permission to use, copy, and distribute this software and its
- *	documentation for any purpose with or without fee is hereby granted,
- *	provided that the above copyright notice appear in all copies and
- *	that both that copyright notice and this permission notice appear
- *	in supporting documentation.
- *
- *      This software is provided "as is" without express or implied warranty.
- */
-
-
-#ifndef MATRIX_H
-#define MATRIX_H
-
-#include "dllexport.h"
-
-
-#ifdef EXT
-#undef EXT
-#endif
-
-#ifdef MATRIX_MAIN
-#define EXT
-#else
-#define EXT extern
-#endif
-
-
-/******* public functions ******/
-
-MZ_DLLEXPORT
-EXT double  *vec (int n);
-MZ_DLLEXPORT
-EXT int     *ivec (int n);
-MZ_DLLEXPORT
-EXT double  **matr (int r, int c);
-MZ_DLLEXPORT
-EXT double  *redim_vec (double **v, int n);
-MZ_DLLEXPORT
-EXT void    redim_ivec (int **v, int n);
-EXT void    solve (double **a, int n, double **b, int m);
-MZ_DLLEXPORT
-EXT void    Givens (double **C, double *d, double *x, double *r, int N, int n, int want_r); 
-MZ_DLLEXPORT
-EXT void    Invert_RtR (double **R, double **I, int n);
-
-#endif
-
-// a kludgy version of a malloc
-
-void * my_gc_malloc(int size);
-void gc_cleanup();
-

src/get-libs.rkt

@@ -84,7 +84,6 @@
       ["libpangocairo-1.0-0.dll" 94625]
       ["libpangowin32-1.0-0.dll" 102210]
       ["libpangoft2-1.0-0.dll" 679322]
-      ["libfit.dll" 73728]
       ,@(if (getenv "PLT_WIN_GTK")
           '(["libatk-1.0-0.dll" 153763]
             ["libgtk-win32-2.0-0.dll" 4740156]
@@ -110,9 +109,8 @@
       ["libgthread-2.0-0.dll" 126615]
       ["libpangocairo-1.0-0.dll" 185168]
       ["libpangowin32-1.0-0.dll" 192656]
-      ["libpangoft2-1.0-0.dll" 1188615]
+      ["libpangoft2-1.0-0.dll" 1188615]]]
-      ["libfit.dll" 69120]]]
+    ;; Database libraries
-    ;; Databse libraries
     [db
      [win32/i386
       ["sqlite3.dll" 570947]]

src/racket/configure.ac

@@ -31,7 +31,6 @@ AC_ARG_ENABLE(jit,     [  --enable-jit            support JIT compiler (enabled
 AC_ARG_ENABLE(foreign, [  --enable-foreign        support foreign calls (enabled by default)], , enable_foreign=yes)
 AC_ARG_ENABLE(places,  [  --enable-places         support places (3m only; usually enabled by default)])
 AC_ARG_ENABLE(futures, [  --enable-futures        support futures (usually enabled by default)])
-AC_ARG_ENABLE(plot,    [  --enable-plot           support plot libraries (enabled by default)], , enable_plot=yes )
 AC_ARG_ENABLE(float,   [  --enable-float          support single-precision floats (enabled by default)], , enable_float=yes)
 AC_ARG_ENABLE(floatinstead, [  --enable-floatinstead   use single-precision by default])
 
@@ -239,7 +238,6 @@ show_explicitly_enabled "${enable_xonx}" "Unix style"
 show_explicitly_enabled "${enable_shared}" "Shared libraries"
 
 show_explicitly_disabled "${enable_gracket}" GRacket
-show_explicitly_disabled "${enable_plot}" Plot fit library
 
 if test "$LIBTOOLPROG" != "" ; then
   echo "=== Libtool program: $LIBTOOLPROG"
@@ -1262,7 +1260,6 @@ AC_SUBST(MRLIBINSTALL)
 AC_SUBST(LIBFINISH)
 
 AC_SUBST(MAKE_GRACKET)
-AC_SUBST(MAKE_FIT)
 AC_SUBST(MAKE_COPYTREE)
 AC_SUBST(MAKE_FINISH)
 
@@ -1340,14 +1337,6 @@ fi
 makefiles="$makefiles foreign/Makefile"
 ac_configure_args="$ac_configure_args$SUB_CONFIGURE_EXTRAS"
 
-if test -d "${srcdir}/fit" && test "${enable_plot}" = "yes" ; then
-  makefiles="$makefiles
-             fit/Makefile"
-  MAKE_FIT=fit
-else
-  MAKE_FIT=no
-fi
-
 if test "${enable_gracket}" = "yes" ; then
   makefiles="$makefiles
              gracket/Makefile

src/racket/src/lightning/i386/fp-sse.h

@@ -35,15 +35,21 @@
 #ifndef __lightning_fp_sse_h
 #define __lightning_fp_sse_h
 
-#define JIT_FPR_NUM	       6
+#ifdef _WIN64
+/* Win64 ABI has only 6 volatile XMM registers, and we need to
+   use one register as scratch: */
+# define JIT_FPR_NUM 5
+#else
+# define JIT_FPR_NUM 6
+#endif
 
 #define _XMM0 0x60
-#ifdef JIT_X86_64
+/* It night be better to avoid the first 8 registers for
-# define JIT_FPR(i) (_XMM0 + 8 + (i))
+   non-Win64 x86_64 mode, since those registers can be
-#else
+   used for arguments in C function calls. Racket doesn't
-# define JIT_FPR(i) (_XMM0 + (i))
+   use FP arguments for C calls, though. */
-#endif
+#define JIT_FPR(i) (_XMM0 + (i))
-#define JIT_FPTMP0 JIT_FPR(6)
+#define JIT_FPTMP0 JIT_FPR(JIT_FPR_NUM)
 
 #define jit_addr_d(f0, f1, f2)                   \
   ((f0 == f1)  \

src/racket/src/port.c

@@ -3191,7 +3191,7 @@ static MZ_INLINE intptr_t get_one_byte(GC_CAN_IGNORE const char *who,
     ip = (Scheme_Input_Port *)port;
     if (!ip->slow) {
       Scheme_Get_String_Fun gs;
-      int v;
+      intptr_t v;
 
       gs = ip->get_string_fun;
 
@@ -8695,7 +8695,7 @@ static void close_subprocess_handle(void *sp, void *ignored)
   CloseHandle(subproc->handle);
 }
 
-static void CopyFileHandleForSubprocess(int *hs, int pos)
+static void CopyFileHandleForSubprocess(intptr_t *hs, int pos)
 {
   HANDLE h2;
   int alt_pos = (pos ? 0 : 1);
@@ -8714,7 +8714,7 @@ static void CopyFileHandleForSubprocess(int *hs, int pos)
   }
 }
 
-static void CloseFileHandleForSubprocess(int *hs, int pos)
+static void CloseFileHandleForSubprocess(intptr_t *hs, int pos)
 {
   int alt_pos = (pos ? 0 : 1);
   if (hs[alt_pos]) {