suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Jay McCarthy 2011-12-26 14:33:20 -07:00
commit 9723e939b4
42 changed files with 721 additions and 6104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/drracket/private/language-configuration.rkt
View File

@ -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))
(set! most-recent-languages-hier-list-selection i)
(define pos (send (send i get-language) get-language-position))
(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
most-recent-languages-hier-list-selection))
(select-a-language-in-hierlist 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]))

98
collects/drracket/private/syncheck/gui.rkt
View File

@ -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)]
[(tail-arrow? arrow) (update-tail-arrow-poss arrow)]))
[(var-arrow? arrow) (get-var-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)
(set-arrow-start-y! arrow start-y)
(set-arrow-end-x! arrow end-x)
(set-arrow-end-y! arrow end-y)))
(values start-x start-y end-x 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,24 +455,22 @@ 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)
(set-arrow-start-y! arrow start-y)
(set-arrow-end-x! arrow end-x)
(set-arrow-end-y! arrow end-y)))
(values start-x start-y end-x end-y)))
(define xlb (box 0))
(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))]
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
[(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)))))
(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))]
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
[(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))))
;; 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
start-text start-pos-left start-pos-right
(let ([arrow (make-var-arrow 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,21 +816,17 @@ 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)
(update-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
#:pen-width 2)
(when (and (var-arrow? arrow) (not (var-arrow-actual? arrow)))
(let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
(send dc draw-text "?"
(+ end-x dx fw)
(+ end-y dy (- fh))))))))]
(define-values (start-x start-y end-x end-y)
(get-arrow-poss 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
#:pen-width 2)
(when (and (var-arrow? arrow) (not (var-arrow-actual? arrow)))
(let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
(send dc draw-text "?"
(+ end-x dx fw)
(+ 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)

32
collects/drracket/private/unit.rkt
View File

@ -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,19 +3985,16 @@ module browser threading seems wrong.
has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-lambda insert-menu))
(new menu:can-restore-menu-item%
[label (if (show-line-numbers?)
(string-constant hide-line-numbers/menu)
(string-constant show-line-numbers/menu))]
[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)))])
(set! show-line-numbers-menu-item
(new menu:can-restore-menu-item%
[label (if (show-line-numbers?)
(string-constant hide-line-numbers/menu)
(string-constant show-line-numbers/menu))]
[parent (get-show-menu)]
[callback (lambda (self event)
(define value (preferences:get 'drracket:show-line-numbers?))
(preferences:set 'drracket:show-line-numbers? (not value))
(show-line-numbers! (not value)))]))
(make-object separator-menu-item% (get-show-menu))

2
collects/meta/dist-specs.rkt
View File

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

2
collects/mred/private/wxme/keymap.rkt
View File

@ -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

868
collects/mysterx/private/mxmain.rkt
View File

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

99
collects/net/unihead.rkt
View File

@ -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)
s
(let ([l (regexp-split #rx"\r\n" s)])
(apply string-append
(map encode-line-for-header l)))))
(cond [(not (regexp-match? re:non-ascii s)) s]
[(not (regexp-match? #rx"\r\n" s)) (encode-line-for-header s)] ; speed
[else (regexp-replace* #rx"[^\r\n]+" s encode-line-for-header)]))
;; 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)
;; Find ASCII (and no "=") prefix before a space
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
(if m
(string-append
(cadr m)
(loop (caddr m) string->bytes charset encode encoding))
(define (do-encode s string->bytes charset encode encoding)
(let loop ([s s])
(cond
;; Find ASCII (and no "=") prefix before a space
[(regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)
=> (λ (m) (string-append (cadr m) (loop (caddr m))))]
;; 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))
#"")))))))
[(regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)
=> (λ (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
[(regexp-match? re:ascii s)
;; ASCII - do nothing
s]
;; ASCII - do nothing
[(not (regexp-match? re:non-ascii s)) s]
;; Not Latin-1, so use UTF-8
[(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
(do-encode s string->bytes/utf-8 "UTF-8" base64-encode-header "B")]
;; use Latin-1
[else
;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")]))
(do-encode s string->bytes/latin-1 "ISO-8859-1" qp-encode-header "Q")]))
;; ----------------------------------------
@ -68,8 +96,7 @@
(if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling
(lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" ")))
(λ (x) (qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64:
base64-decode)
(cadddr (cdr m)))]

5
collects/plot/compat.rkt
View File

@ -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)

56
collects/plot/deprecated/fit-low-level.rkt
View File

@ -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))

57
collects/plot/deprecated/fit.rkt
View File

@ -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))))

110
collects/plot/scribblings/compat.scrbl
View File

@ -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])

2
collects/plot/scribblings/porting.scrbl
View File

@ -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.

1155
collects/plot/tests/fit-test-1.rkt
View File

File diff suppressed because it is too large Load Diff

2635
collects/plot/tests/fit-test-2.rkt
View File

File diff suppressed because it is too large Load Diff

BIN
collects/plot/tests/sqr.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 12 KiB

BIN
collects/plot/tests/trig.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 69 KiB

20
collects/racket/draw/private/dc-path.rkt
View File

@ -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!)

59
collects/racket/draw/private/dc.rkt
View File

@ -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))))))))
@ -1518,7 +1532,7 @@
(vector-set! vec 2 #f)
(vector-set! vec 3 #f)
(vector-set! vec 4 #f)))))
(def/public (start-doc [string? desc])
(check-ok 'start-doc))
(def/public (end-doc)
@ -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))))

34
collects/racket/draw/private/record-dc.rkt
View File

@ -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)

56
collects/racket/draw/unsafe/cairo.rkt
View File

@ -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))))))))

1
collects/racket/draw/unsafe/pango.rkt
View File

@ -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))

9
collects/scribble/text-render.rkt
View File

@ -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)))

15
collects/scribblings/draw/dc-path-class.scrbl
View File

@ -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?]{

4
collects/slideshow/tutorial-show.rkt
View File

@ -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"))

35
collects/tests/gracket/draw.rkt
View File

@ -65,11 +65,12 @@
(send f show #t)))
(define star
(list (make-object point% 30 0)
(make-object point% 48 60)
(make-object point% 0 20)
(make-object point% 60 20)
(make-object point% 12 60)))
;; uses pairs instead of point%s
(list (cons 30 0)
(cons 48 60)
(cons 0 20)
(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)))

59
collects/tests/gracket/record-dc.rkt Normal file
View File

@ -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"))

1
doc/release-notes/racket/HISTORY.txt
View File

@ -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?

15
src/Makefile.in
View File

@ -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
# and link C code:
# collection-setup actions that compile 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)

43
src/README
View File

@ -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
Cairo, Pango, and GTk. These libraries are not distributed with
Racket. The configure process checks automatically whether these
libraries are available.
To run `racket/draw' and `racket/gui' programs, you will need
Cairo, Pango, and GTk install. These libraries are not
distributed with Racket, and they are not needed for compilation,
except for building documentation that uses `racket/draw'.
Finally, the content of the "foreign" subdirectory may require GNU
`make'. If the build fails with another variant of `make', please
try using GNU `make'.
The content of the "foreign" subdirectory may require GNU `make'
if no installed "libffi" is detected. If the build fails with
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
DrRacket. Use `make plain-install' to install without compiling
".zo" files or creating launchers.
installed Racket source, generates launcher programs like
DrRacket, and builds documentation. Use `make plain-install' to
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
floating point numbers. This and other options can be modified by
setting flags in "racket/sconfig.h".
Athough `configure' flags control most options, some configrations
options can be modified by setting flags in "racket/sconfig.h".
Modifying Racket
----------------

22
src/configure vendored
View File

@ -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

37
src/fit/Makefile.in
View File

@ -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@"

1
src/fit/build.bat
View File

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

32
src/fit/build.rkt
View File

@ -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))))))

6
src/fit/dllexport.h
View File

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

752
src/fit/fit.c
View File

@ -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;
}
}

62
src/fit/fit.h
View File

@ -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();

315
src/fit/matrix.c
View File

@ -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];
}
}

75
src/fit/matrix.h
View File

@ -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();

6
src/get-libs.rkt
View File

@ -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]
["libfit.dll" 69120]]]
;; Databse libraries
["libpangoft2-1.0-0.dll" 1188615]]]
;; Database libraries
[db
[win32/i386
["sqlite3.dll" 570947]]

11
src/racket/configure.ac
View File

@ -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

20
src/racket/src/lightning/i386/fp-sse.h
View File

@ -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
# define JIT_FPR(i) (_XMM0 + 8 + (i))
#else
# define JIT_FPR(i) (_XMM0 + (i))
#endif
#define JIT_FPTMP0 JIT_FPR(6)
/* It night be better to avoid the first 8 registers for
non-Win64 x86_64 mode, since those registers can be
used for arguments in C function calls. Racket doesn't
use FP arguments for C calls, though. */
#define JIT_FPR(i) (_XMM0 + (i))
#define JIT_FPTMP0 JIT_FPR(JIT_FPR_NUM)
#define jit_addr_d(f0, f1, f2) \
((f0 == f1) \

6
src/racket/src/port.c
View File

@ -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]) {