Racket & GRacket relesae notes for 5.0.1
Merge to 5.0.1 original commit: e49f05a5cbb3e78e0ff051a7a6e35f2c35ab3a12
This commit is contained in:
Matthew Flatt
commit
10a8e6ad6e
|
|
@ -7,7 +7,7 @@
|
||||||
|
|
||||||
(define-runtime-path here ".")
|
(define-runtime-path here ".")
|
||||||
|
|
||||||
(define standard-menus.ss-filename (simplify-path (build-path here "standard-menus.ss")))
|
(define standard-menus.rkt-filename (simplify-path (build-path here "standard-menus.rkt")))
|
||||||
(define docs-menus.ss-filename (simplify-path (build-path here 'up 'up "scribblings" "framework" "standard-menus.scrbl")))
|
(define docs-menus.ss-filename (simplify-path (build-path here 'up 'up "scribblings" "framework" "standard-menus.scrbl")))
|
||||||
|
|
||||||
;; build-before-super-item-clause : an-item -> (listof clause)
|
;; build-before-super-item-clause : an-item -> (listof clause)
|
||||||
|
|
@ -121,7 +121,7 @@
|
||||||
,(generic-initializer generic)))]))
|
,(generic-initializer generic)))]))
|
||||||
|
|
||||||
(define (main)
|
(define (main)
|
||||||
(write-standard-menus.ss)
|
(write-standard-menus.rkt)
|
||||||
(write-docs))
|
(write-docs))
|
||||||
|
|
||||||
(define (write-docs)
|
(define (write-docs)
|
||||||
|
|
@ -202,10 +202,10 @@
|
||||||
(display docs-footer-text port))
|
(display docs-footer-text port))
|
||||||
#:exists 'truncate))
|
#:exists 'truncate))
|
||||||
|
|
||||||
(define (write-standard-menus.ss)
|
(define (write-standard-menus.rkt)
|
||||||
(printf "writing to ~a~n" standard-menus.ss-filename)
|
(printf "writing to ~a~n" standard-menus.rkt-filename)
|
||||||
|
|
||||||
(call-with-output-file standard-menus.ss-filename
|
(call-with-output-file standard-menus.rkt-filename
|
||||||
(λ (port)
|
(λ (port)
|
||||||
(pretty-print
|
(pretty-print
|
||||||
`(define standard-menus<%>
|
`(define standard-menus<%>
|
||||||
|
|
|
||||||
|
|
@ -208,7 +208,7 @@
|
||||||
(let ([hash-table (make-hasheq)])
|
(let ([hash-table (make-hasheq)])
|
||||||
(for-each (λ (x)
|
(for-each (λ (x)
|
||||||
(hash-set! hash-table x 'define))
|
(hash-set! hash-table x 'define))
|
||||||
'(local))
|
'(struct local))
|
||||||
(for-each (λ (x)
|
(for-each (λ (x)
|
||||||
(hash-set! hash-table x 'begin))
|
(hash-set! hash-table x 'begin))
|
||||||
'(case-lambda
|
'(case-lambda
|
||||||
|
|
|
||||||
|
|
@ -280,7 +280,7 @@
|
||||||
(string-constant quit-menu-item-windows)
|
(string-constant quit-menu-item-windows)
|
||||||
(string-constant quit-menu-item-others))
|
(string-constant quit-menu-item-others))
|
||||||
on-demand-do-nothing
|
on-demand-do-nothing
|
||||||
'(not (current-eventspace-has-standard-menus?)))
|
'(not (eq? (system-type) 'macosx)))
|
||||||
(make-after 'file-menu 'quit 'nothing)
|
(make-after 'file-menu 'quit 'nothing)
|
||||||
|
|
||||||
(make-an-item 'edit-menu 'undo
|
(make-an-item 'edit-menu 'undo
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,4 @@
|
||||||
#reader scribble/reader
|
#lang at-exp scheme/gui
|
||||||
#lang scheme/gui
|
|
||||||
|
|
||||||
(require scribble/srcdoc)
|
(require scribble/srcdoc)
|
||||||
(require/doc scheme/base scribble/manual)
|
(require/doc scheme/base scribble/manual)
|
||||||
|
|
@ -355,8 +354,7 @@
|
||||||
state in-cb
|
state in-cb
|
||||||
(build-labels rb))]
|
(build-labels rb))]
|
||||||
[else (let ([i (- total n)])
|
[else (let ([i (- total n)])
|
||||||
(if (or (string=? state (send rb get-item-label i))
|
(if (ith-item-matches? rb state i)
|
||||||
(string=? state (send rb get-item-plain-label i)))
|
|
||||||
(if (send rb is-enabled? i)
|
(if (send rb is-enabled? i)
|
||||||
(send rb set-selection i)
|
(send rb set-selection i)
|
||||||
(error 'test:set-radio-box!
|
(error 'test:set-radio-box!
|
||||||
|
|
@ -371,6 +369,15 @@
|
||||||
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
||||||
state in-cb)]))))
|
state in-cb)]))))
|
||||||
|
|
||||||
|
(define (ith-item-matches? rb state i)
|
||||||
|
(cond
|
||||||
|
[(string? state)
|
||||||
|
(or (string=? state (send rb get-item-label i))
|
||||||
|
(string=? state (send rb get-item-plain-label i)))]
|
||||||
|
[(regexp? state)
|
||||||
|
(or (regexp-match state (send rb get-item-label i))
|
||||||
|
(regexp-match state (send rb get-item-plain-label i)))]))
|
||||||
|
|
||||||
;; set-radio-box-item! : string -> void
|
;; set-radio-box-item! : string -> void
|
||||||
(define (set-radio-box-item! state)
|
(define (set-radio-box-item! state)
|
||||||
(control-action
|
(control-action
|
||||||
|
|
@ -383,8 +390,7 @@
|
||||||
(cond
|
(cond
|
||||||
[(zero? n) (error 'test:set-radio-box-item! "internal error")]
|
[(zero? n) (error 'test:set-radio-box-item! "internal error")]
|
||||||
[else (let ([i (- total n)])
|
[else (let ([i (- total n)])
|
||||||
(if (or (string=? state (send rb get-item-label i))
|
(if (ith-item-matches? rb state i)
|
||||||
(string=? state (send rb get-item-plain-label i)))
|
|
||||||
(if (send rb is-enabled? i)
|
(if (send rb is-enabled? i)
|
||||||
(send rb set-selection i)
|
(send rb set-selection i)
|
||||||
(error 'test:set-radio-box!
|
(error 'test:set-radio-box!
|
||||||
|
|
@ -392,14 +398,23 @@
|
||||||
state))
|
state))
|
||||||
(loop (- n 1))))]))))))
|
(loop (- n 1))))]))))))
|
||||||
|
|
||||||
;; entry-matches : string -> radio-box -> boolean
|
;; entry-matches : string | regexp -> radio-box -> boolean
|
||||||
(define (entry-matches name)
|
(define (entry-matches name)
|
||||||
(λ (rb)
|
(λ (rb)
|
||||||
(let loop ([n (send rb get-number)])
|
(let loop ([n (send rb get-number)])
|
||||||
(and (not (zero? n))
|
(cond
|
||||||
(or (equal? name (send rb get-item-label (- n 1)))
|
[(zero? n) #f]
|
||||||
(equal? name (send rb get-item-plain-label (- n 1)))
|
[else
|
||||||
(loop (- n 1)))))))
|
(let ([itm (send rb get-item-label (- n 1))]
|
||||||
|
[pln-itm (send rb get-item-plain-label (- n 1))])
|
||||||
|
(or (cond
|
||||||
|
[(string? name)
|
||||||
|
(or (equal? name itm)
|
||||||
|
(equal? name pln-itm))]
|
||||||
|
[(regexp? name)
|
||||||
|
(or (regexp-match name itm)
|
||||||
|
(regexp-match name pln-itm))])
|
||||||
|
(loop (- n 1))))]))))
|
||||||
|
|
||||||
;;; CHOICE
|
;;; CHOICE
|
||||||
|
|
||||||
|
|
@ -844,11 +859,12 @@
|
||||||
|
|
||||||
(proc-doc/names
|
(proc-doc/names
|
||||||
test:set-radio-box!
|
test:set-radio-box!
|
||||||
(-> (or/c string? (is-a?/c radio-box%)) (or/c string? number?) void?)
|
(-> (or/c string? regexp? (is-a?/c radio-box%)) (or/c string? number?) void?)
|
||||||
(radio-box state)
|
(radio-box state)
|
||||||
@{Sets the radio-box to @scheme[state]. If @scheme[state] is a
|
@{Sets the radio-box to the label matching @scheme[state]. If @scheme[state] is a
|
||||||
string, this function finds the choice with that label and
|
string, this function finds the choice with that label.
|
||||||
if it is a number, it uses the number as an index into the
|
If it is a regexp, this function finds the first choice whose label matches the regexp.
|
||||||
|
If it is a number, it uses the number as an index into the
|
||||||
state. If the number is out of range or if the label isn't
|
state. If the number is out of range or if the label isn't
|
||||||
in the radio box, an exception is raised.
|
in the radio box, an exception is raised.
|
||||||
|
|
||||||
|
|
@ -858,9 +874,9 @@
|
||||||
|
|
||||||
(proc-doc/names
|
(proc-doc/names
|
||||||
test:set-radio-box-item!
|
test:set-radio-box-item!
|
||||||
(-> string? void?)
|
(-> (or/c string? regexp?) void?)
|
||||||
(entry)
|
(entry)
|
||||||
@{Finds a @scheme[radio-box%] that has a label @scheme[entry]
|
@{Finds a @scheme[radio-box%] that has a label matching @scheme[entry]
|
||||||
and sets the radio-box to @scheme[entry].})
|
and sets the radio-box to @scheme[entry].})
|
||||||
|
|
||||||
(proc-doc/names
|
(proc-doc/names
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
(module mred mzscheme
|
(module mred mzscheme
|
||||||
(require (only scheme/base
|
(require (only racket/base
|
||||||
define-namespace-anchor
|
define-namespace-anchor
|
||||||
namespace-anchor->empty-namespace
|
namespace-anchor->empty-namespace
|
||||||
make-base-empty-namespace)
|
make-base-empty-namespace)
|
||||||
|
|
@ -57,6 +57,9 @@
|
||||||
(wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
|
(wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; These functions are re-implemented in scheme/gui/base
|
||||||
|
;; and racket/gui/base to attach those names, instead of
|
||||||
|
;; just 'mred.
|
||||||
|
|
||||||
(define-namespace-anchor anchor)
|
(define-namespace-anchor anchor)
|
||||||
|
|
||||||
|
|
@ -75,6 +78,8 @@
|
||||||
(namespace-require 'scheme/class))
|
(namespace-require 'scheme/class))
|
||||||
ns))
|
ns))
|
||||||
|
|
||||||
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (make-eventspace)
|
(define (make-eventspace)
|
||||||
(parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
|
(parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
|
||||||
[wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
|
[wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
|
||||||
|
|
|
||||||
|
|
@ -159,6 +159,7 @@
|
||||||
|
|
||||||
(define changed? #f)
|
(define changed? #f)
|
||||||
|
|
||||||
|
(define prev-mouse-snip #f)
|
||||||
|
|
||||||
(super-new)
|
(super-new)
|
||||||
|
|
||||||
|
|
@ -241,28 +242,42 @@
|
||||||
(def/override (on-event [mouse-event% event])
|
(def/override (on-event [mouse-event% event])
|
||||||
(when s-admin
|
(when s-admin
|
||||||
(let-values ([(dc x y scrollx scrolly)
|
(let-values ([(dc x y scrollx scrolly)
|
||||||
(if (or (send event button-down?) s-caret-snip)
|
;; first, find clicked-on snip:
|
||||||
;; first, find clicked-on snip:
|
(let ([x (send event get-x)]
|
||||||
(let ([x (send event get-x)]
|
[y (send event get-y)])
|
||||||
[y (send event get-y)])
|
(let-boxes ([scrollx 0.0]
|
||||||
(let-boxes ([scrollx 0.0]
|
[scrolly 0.0]
|
||||||
[scrolly 0.0]
|
[dc #f])
|
||||||
[dc #f])
|
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
||||||
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
;; FIXME: old code returned if !dc
|
||||||
;; FIXME: old code returned if !dc
|
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
|
||||||
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
|
(let ([snip (find-snip x y)])
|
||||||
(values #f 0.0 0.0 0.0 0.0))])
|
(when (and prev-mouse-snip
|
||||||
(let ([snip (if (send event button-down?)
|
(not (eq? snip prev-mouse-snip)))
|
||||||
(find-snip x y)
|
(let ([loc (snip-loc prev-mouse-snip)])
|
||||||
s-caret-snip)])
|
(send prev-mouse-snip on-event
|
||||||
(if (and snip
|
|
||||||
(eq? snip s-caret-snip))
|
|
||||||
(let ([loc (snip-loc snip)])
|
|
||||||
(send s-caret-snip on-event
|
|
||||||
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
|
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
|
||||||
(loc-x loc) (loc-y loc)
|
(loc-x loc) (loc-y loc)
|
||||||
event))
|
event)))
|
||||||
(on-local-event event))))))
|
(set! prev-mouse-snip #f)
|
||||||
|
(when (and snip
|
||||||
|
(has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS)
|
||||||
|
(not (eq? snip s-caret-snip)))
|
||||||
|
(let ([loc (snip-loc snip)])
|
||||||
|
(set! prev-mouse-snip snip)
|
||||||
|
(send snip on-event
|
||||||
|
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
|
||||||
|
(loc-x loc) (loc-y loc)
|
||||||
|
event)))
|
||||||
|
(if (and s-caret-snip
|
||||||
|
(or (not (send event button-down?))
|
||||||
|
(eq? snip s-caret-snip)))
|
||||||
|
(let ([loc (snip-loc s-caret-snip)])
|
||||||
|
(send s-caret-snip on-event
|
||||||
|
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
|
||||||
|
(loc-x loc) (loc-y loc)
|
||||||
|
event))
|
||||||
|
(on-local-event event))))))
|
||||||
|
|
||||||
(def/override (on-default-event [mouse-event% event])
|
(def/override (on-default-event [mouse-event% event])
|
||||||
(when s-admin
|
(when s-admin
|
||||||
|
|
@ -729,6 +744,8 @@
|
||||||
|
|
||||||
(define/private (-delete del-snip del)
|
(define/private (-delete del-snip del)
|
||||||
(when (snip-loc del-snip)
|
(when (snip-loc del-snip)
|
||||||
|
(when (eq? del-snip prev-mouse-snip)
|
||||||
|
(set! prev-mouse-snip #f))
|
||||||
(set! write-locked (add1 write-locked))
|
(set! write-locked (add1 write-locked))
|
||||||
(begin-edit-sequence)
|
(begin-edit-sequence)
|
||||||
(let ([ok? (or (can-delete? del-snip)
|
(let ([ok? (or (can-delete? del-snip)
|
||||||
|
|
|
||||||
|
|
@ -170,6 +170,8 @@
|
||||||
(define sticky-styles? #t)
|
(define sticky-styles? #t)
|
||||||
(define overwrite-mode? #f)
|
(define overwrite-mode? #f)
|
||||||
|
|
||||||
|
(define prev-mouse-snip #f)
|
||||||
|
|
||||||
(def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t)))
|
(def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t)))
|
||||||
(def/public (get-styles-sticky) sticky-styles?)
|
(def/public (get-styles-sticky) sticky-styles?)
|
||||||
|
|
||||||
|
|
@ -441,18 +443,15 @@
|
||||||
(not (send event leaving?)))
|
(not (send event leaving?)))
|
||||||
(end-streaks '(except-key-sequence cursor delayed)))
|
(end-streaks '(except-key-sequence cursor delayed)))
|
||||||
(let-values ([(dc x y scrollx scrolly)
|
(let-values ([(dc x y scrollx scrolly)
|
||||||
(if (or (send event button-down?) s-caret-snip)
|
;; first, find clicked-on snip:
|
||||||
;; first, find clicked-on snip:
|
(let ([x (send event get-x)]
|
||||||
(let ([x (send event get-x)]
|
[y (send event get-y)])
|
||||||
[y (send event get-y)])
|
(let-boxes ([scrollx 0.0]
|
||||||
(let-boxes ([scrollx 0.0]
|
[scrolly 0.0]
|
||||||
[scrolly 0.0]
|
[dc #f])
|
||||||
[dc #f])
|
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
||||||
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
;; FIXME: old code returned if !dc
|
||||||
;; FIXME: old code returned if !dc
|
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
|
||||||
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
|
|
||||||
(values #f 0.0 0.0 0.0 0.0))])
|
|
||||||
(when (send event button-down?)
|
|
||||||
(let ([snip
|
(let ([snip
|
||||||
(let-boxes ([onit? #f]
|
(let-boxes ([onit? #f]
|
||||||
[how-close 0.0]
|
[how-close 0.0]
|
||||||
|
|
@ -476,12 +475,26 @@
|
||||||
#f
|
#f
|
||||||
snip)))
|
snip)))
|
||||||
#f)))])
|
#f)))])
|
||||||
(set-caret-owner snip)))
|
(when (send event button-down?)
|
||||||
(if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
|
(set-caret-owner snip))
|
||||||
(let-boxes ([x 0.0] [y 0.0])
|
(when (and prev-mouse-snip
|
||||||
(get-snip-position-and-location s-caret-snip #f x y)
|
(not (eq? snip prev-mouse-snip)))
|
||||||
(send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event))
|
(let-boxes ([x 0.0] [y 0.0])
|
||||||
(on-local-event event)))))
|
(get-snip-position-and-location prev-mouse-snip #f x y)
|
||||||
|
(send prev-mouse-snip on-event dc (- x scrollx) (- y scrolly) x y event)))
|
||||||
|
(set! prev-mouse-snip #f)
|
||||||
|
(if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
|
||||||
|
(let-boxes ([x 0.0] [y 0.0])
|
||||||
|
(get-snip-position-and-location s-caret-snip #f x y)
|
||||||
|
(send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event))
|
||||||
|
(begin
|
||||||
|
(when (and snip
|
||||||
|
(has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS))
|
||||||
|
(let-boxes ([x 0.0] [y 0.0])
|
||||||
|
(get-snip-position-and-location snip #f x y)
|
||||||
|
(set! prev-mouse-snip snip)
|
||||||
|
(send snip on-event dc (- x scrollx) (- y scrolly) x y event)))
|
||||||
|
(on-local-event event)))))))
|
||||||
|
|
||||||
(def/override (on-default-event [mouse-event% event])
|
(def/override (on-default-event [mouse-event% event])
|
||||||
(when s-admin
|
(when s-admin
|
||||||
|
|
@ -4004,6 +4017,8 @@
|
||||||
(set! snip-count (add1 snip-count)))))
|
(set! snip-count (add1 snip-count)))))
|
||||||
|
|
||||||
(define/private (delete-snip snip)
|
(define/private (delete-snip snip)
|
||||||
|
(when (eq? snip prev-mouse-snip)
|
||||||
|
(set! prev-mouse-snip #f))
|
||||||
(cond
|
(cond
|
||||||
[(snip->next snip)
|
[(snip->next snip)
|
||||||
(splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))]
|
(splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))]
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,10 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
|
;; changed:
|
||||||
|
;; - simple-shape
|
||||||
|
;; - np-atomic-shape
|
||||||
|
;; - atomic-shape
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
||||||
This library is the part of the 2htdp/image
|
This library is the part of the 2htdp/image
|
||||||
|
|
@ -29,7 +35,9 @@ has been moved out).
|
||||||
(require racket/class
|
(require racket/class
|
||||||
racket/gui/base
|
racket/gui/base
|
||||||
racket/math
|
racket/math
|
||||||
|
racket/contract
|
||||||
"private/image-core-bitmap.ss"
|
"private/image-core-bitmap.ss"
|
||||||
|
(prefix-in cis: "cache-image-snip.ss")
|
||||||
(for-syntax racket/base))
|
(for-syntax racket/base))
|
||||||
|
|
||||||
(define-for-syntax id-constructor-pairs '())
|
(define-for-syntax id-constructor-pairs '())
|
||||||
|
|
@ -122,6 +130,7 @@ has been moved out).
|
||||||
;; - polygon
|
;; - polygon
|
||||||
;; - line-segment
|
;; - line-segment
|
||||||
;; - curve-segment
|
;; - curve-segment
|
||||||
|
;; - bitmap
|
||||||
;; - np-atomic-shape
|
;; - np-atomic-shape
|
||||||
|
|
||||||
;; a np-atomic-shape is:
|
;; a np-atomic-shape is:
|
||||||
|
|
@ -135,11 +144,22 @@ has been moved out).
|
||||||
(define-struct/reg-mk text (string angle y-scale color size face family style weight underline)
|
(define-struct/reg-mk text (string angle y-scale color size face family style weight underline)
|
||||||
#:omit-define-syntaxes #:transparent)
|
#:omit-define-syntaxes #:transparent)
|
||||||
;;
|
;;
|
||||||
|
;; - flip
|
||||||
|
|
||||||
|
;; a bitmap is:
|
||||||
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
|
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
|
||||||
;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
|
;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
|
||||||
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
|
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
|
||||||
#:omit-define-syntaxes #:transparent)
|
#:omit-define-syntaxes #:transparent)
|
||||||
|
|
||||||
|
;; a flip is:
|
||||||
|
;; - (make-flip boolean bitmap)
|
||||||
|
;; * the boolean is #t if the bitmap should be flipped vertically (after applying whatever rotation is in there)
|
||||||
|
;; * this struct is here to avoid adding a field to bitmaps, so that old save files
|
||||||
|
;; from when the library did not support flipping still load
|
||||||
|
;; (since normalization will add a flip structure if necessary)
|
||||||
|
(define-struct/reg-mk flip (flipped? shape))
|
||||||
|
|
||||||
;; a polygon is:
|
;; a polygon is:
|
||||||
;;
|
;;
|
||||||
;; - (make-polygon (listof vector) mode color)
|
;; - (make-polygon (listof vector) mode color)
|
||||||
|
|
@ -164,7 +184,7 @@ has been moved out).
|
||||||
;; - (make-crop (listof points) normalized-shape)
|
;; - (make-crop (listof points) normalized-shape)
|
||||||
|
|
||||||
;; a simple-shape (subtype of shape) is
|
;; a simple-shape (subtype of shape) is
|
||||||
;; - (make-translate dx dy np-atomic-shape))
|
;; - (make-translate dx dy np-atomic-shape)
|
||||||
;; - polygon
|
;; - polygon
|
||||||
;; - line-segment
|
;; - line-segment
|
||||||
;; - curve-segment
|
;; - curve-segment
|
||||||
|
|
@ -213,21 +233,26 @@ has been moved out).
|
||||||
(init-field shape bb normalized?)
|
(init-field shape bb normalized?)
|
||||||
(define/public (equal-to? that eq-recur)
|
(define/public (equal-to? that eq-recur)
|
||||||
(or (eq? this that)
|
(or (eq? this that)
|
||||||
(and (is-a? that image%)
|
(let ([that
|
||||||
(same-bb? bb (send that get-bb))
|
(cond
|
||||||
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
|
[(is-a? that image-snip%) (image-snip->image that)]
|
||||||
(equal? (get-normalized-shape) (send that get-normalized-shape)))
|
[(is-a? that bitmap%) (bitmap->image that)]
|
||||||
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box
|
[else that])])
|
||||||
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that.
|
(and (is-a? that image%)
|
||||||
(or (zero? w)
|
(same-bb? bb (send that get-bb))
|
||||||
(zero? h)
|
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
|
||||||
(let ([bm1 (make-object bitmap% w h)]
|
(equal? (get-normalized-shape) (send that get-normalized-shape)))
|
||||||
[bm2 (make-object bitmap% w h)]
|
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box
|
||||||
[bytes1 (make-bytes (* w h 4) 0)]
|
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that.
|
||||||
[bytes2 (make-bytes (* w h 4) 0)]
|
(or (zero? w)
|
||||||
[bdc (make-object bitmap-dc%)])
|
(zero? h)
|
||||||
(and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
|
(let ([bm1 (make-object bitmap% w h)]
|
||||||
(check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))
|
[bm2 (make-object bitmap% w h)]
|
||||||
|
[bytes1 (make-bytes (* w h 4) 0)]
|
||||||
|
[bytes2 (make-bytes (* w h 4) 0)]
|
||||||
|
[bdc (make-object bitmap-dc%)])
|
||||||
|
(and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
|
||||||
|
(check-same? bm1 bm2 bytes1 bytes2 bdc "green" that))))))))))
|
||||||
|
|
||||||
(define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
|
(define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
|
||||||
(clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
|
(clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
|
||||||
|
|
@ -369,9 +394,49 @@ has been moved out).
|
||||||
|
|
||||||
(define-id->constructor id->constructor)
|
(define-id->constructor id->constructor)
|
||||||
|
|
||||||
|
|
||||||
|
(define (normalized-shape? s)
|
||||||
|
(cond
|
||||||
|
[(overlay? s)
|
||||||
|
(and (normalized-shape? (overlay-top s))
|
||||||
|
(cn-or-simple-shape? (overlay-bottom s)))]
|
||||||
|
[else
|
||||||
|
(cn-or-simple-shape? s)]))
|
||||||
|
|
||||||
|
(define (cn-or-simple-shape? s)
|
||||||
|
(cond
|
||||||
|
[(crop? s)
|
||||||
|
(normalized-shape? (crop-shape s))]
|
||||||
|
[else
|
||||||
|
(simple-shape? s)]))
|
||||||
|
|
||||||
|
(define (simple-shape? shape)
|
||||||
|
(or (and (translate? shape)
|
||||||
|
(np-atomic-shape? (translate-shape shape)))
|
||||||
|
(polygon? shape)
|
||||||
|
(line-segment? shape)
|
||||||
|
(curve-segment? shape)))
|
||||||
|
|
||||||
|
(define (atomic-shape? shape)
|
||||||
|
(or (polygon? shape)
|
||||||
|
(line-segment? shape)
|
||||||
|
(curve-segment? shape)
|
||||||
|
(bitmap? shape)
|
||||||
|
(np-atomic-shape? shape)))
|
||||||
|
|
||||||
|
(define (np-atomic-shape? shape)
|
||||||
|
(or (ellipse? shape)
|
||||||
|
(text? shape)
|
||||||
|
(and (flip? shape)
|
||||||
|
(boolean? (flip-flipped? shape))
|
||||||
|
(bitmap? (flip-shape shape)))))
|
||||||
|
|
||||||
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
|
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
|
||||||
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
|
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
|
||||||
(define (normalize-shape shape [f values])
|
(define/contract (normalize-shape shape [f values])
|
||||||
|
(->* (any/c) ;; should be shape?
|
||||||
|
((-> any/c any/c))
|
||||||
|
normalized-shape?)
|
||||||
(let loop ([shape shape]
|
(let loop ([shape shape]
|
||||||
[dx 0]
|
[dx 0]
|
||||||
[dy 0]
|
[dy 0]
|
||||||
|
|
@ -443,50 +508,20 @@ has been moved out).
|
||||||
(if bottom
|
(if bottom
|
||||||
(make-overlay bottom (f this-one))
|
(make-overlay bottom (f this-one))
|
||||||
(f this-one)))]
|
(f this-one)))]
|
||||||
[(np-atomic-shape? shape)
|
[(or (bitmap? shape) (np-atomic-shape? shape))
|
||||||
(let ([this-one
|
(let ([shape (if (bitmap? shape)
|
||||||
(make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
|
(make-flip #f shape)
|
||||||
(if bottom
|
shape)])
|
||||||
(make-overlay bottom (f this-one))
|
(let ([this-one
|
||||||
(f this-one)))]
|
(make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
|
||||||
|
(if bottom
|
||||||
|
(make-overlay bottom (f this-one))
|
||||||
|
(f this-one))))]
|
||||||
[else
|
[else
|
||||||
(error 'normalize-shape "unknown shape ~s\n" shape)])))
|
(error 'normalize-shape "unknown shape ~s\n" shape)])))
|
||||||
|
|
||||||
(define (normalized-shape? s)
|
(define/contract (scale-np-atomic x-scale y-scale shape)
|
||||||
(cond
|
(-> number? number? np-atomic-shape? np-atomic-shape?)
|
||||||
[(overlay? s)
|
|
||||||
(and (normalized-shape? (overlay-top s))
|
|
||||||
(cn-or-simple-shape? (overlay-bottom s)))]
|
|
||||||
[else
|
|
||||||
(cn-or-simple-shape? s)]))
|
|
||||||
|
|
||||||
(define (cn-or-simple-shape? s)
|
|
||||||
(cond
|
|
||||||
[(crop? s)
|
|
||||||
(normalized-shape? (crop-shape s))]
|
|
||||||
[else
|
|
||||||
(simple-shape? s)]))
|
|
||||||
|
|
||||||
(define (simple-shape? shape)
|
|
||||||
(or (and (translate? shape)
|
|
||||||
(np-atomic-shape? (translate-shape shape)))
|
|
||||||
(polygon? shape)
|
|
||||||
(line-segment? shape)
|
|
||||||
(curve-segment? shape)))
|
|
||||||
|
|
||||||
(define (atomic-shape? shape)
|
|
||||||
(or (polygon? shape)
|
|
||||||
(line-segment? shape)
|
|
||||||
(curve-segment? shape)
|
|
||||||
(np-atomic-shape? shape)))
|
|
||||||
|
|
||||||
(define (np-atomic-shape? shape)
|
|
||||||
(or (ellipse? shape)
|
|
||||||
(text? shape)
|
|
||||||
(bitmap? shape)
|
|
||||||
(point? shape)))
|
|
||||||
|
|
||||||
(define (scale-np-atomic x-scale y-scale shape)
|
|
||||||
(cond
|
(cond
|
||||||
[(ellipse? shape)
|
[(ellipse? shape)
|
||||||
(make-ellipse (* x-scale (ellipse-width shape))
|
(make-ellipse (* x-scale (ellipse-width shape))
|
||||||
|
|
@ -508,13 +543,15 @@ has been moved out).
|
||||||
(text-style shape)
|
(text-style shape)
|
||||||
(text-weight shape)
|
(text-weight shape)
|
||||||
(text-underline shape))]
|
(text-underline shape))]
|
||||||
[(bitmap? shape)
|
[(flip? shape)
|
||||||
(make-bitmap (bitmap-raw-bitmap shape)
|
(let ([bitmap (flip-shape shape)])
|
||||||
(bitmap-raw-mask shape)
|
(make-flip (flip-flipped? shape)
|
||||||
(bitmap-angle shape)
|
(make-bitmap (bitmap-raw-bitmap bitmap)
|
||||||
(* x-scale (bitmap-x-scale shape))
|
(bitmap-raw-mask bitmap)
|
||||||
(* y-scale (bitmap-y-scale shape))
|
(bitmap-angle bitmap)
|
||||||
#f #f)]))
|
(* x-scale (bitmap-x-scale bitmap))
|
||||||
|
(* y-scale (bitmap-y-scale bitmap))
|
||||||
|
#f #f)))]))
|
||||||
|
|
||||||
(define (scale-color color x-scale y-scale)
|
(define (scale-color color x-scale y-scale)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -552,7 +589,13 @@ has been moved out).
|
||||||
[font (send dc get-font)]
|
[font (send dc get-font)]
|
||||||
[fg (send dc get-text-foreground)]
|
[fg (send dc get-text-foreground)]
|
||||||
[smoothing (send dc get-smoothing)])
|
[smoothing (send dc get-smoothing)])
|
||||||
(render-normalized-shape (send image get-normalized-shape) dc dx dy)
|
(cond
|
||||||
|
[(is-a? image bitmap%)
|
||||||
|
(send dc draw-bitmap image dx dy)]
|
||||||
|
[(is-a? image image-snip%)
|
||||||
|
(send dc draw-bitmap (send image get-bitmap) dx dy)]
|
||||||
|
[else
|
||||||
|
(render-normalized-shape (send image get-normalized-shape) dc dx dy)])
|
||||||
(send dc set-pen pen)
|
(send dc set-pen pen)
|
||||||
(send dc set-brush brush)
|
(send dc set-brush brush)
|
||||||
(send dc set-font font)
|
(send dc set-font font)
|
||||||
|
|
@ -652,15 +695,15 @@ has been moved out).
|
||||||
[else
|
[else
|
||||||
(let ([dx (+ dx (translate-dx simple-shape))]
|
(let ([dx (+ dx (translate-dx simple-shape))]
|
||||||
[dy (+ dy (translate-dy simple-shape))]
|
[dy (+ dy (translate-dy simple-shape))]
|
||||||
[atomic-shape (translate-shape simple-shape)])
|
[np-atomic-shape (translate-shape simple-shape)])
|
||||||
(cond
|
(cond
|
||||||
[(ellipse? atomic-shape)
|
[(ellipse? np-atomic-shape)
|
||||||
(let* ([path (new dc-path%)]
|
(let* ([path (new dc-path%)]
|
||||||
[ew (ellipse-width atomic-shape)]
|
[ew (ellipse-width np-atomic-shape)]
|
||||||
[eh (ellipse-height atomic-shape)]
|
[eh (ellipse-height np-atomic-shape)]
|
||||||
[θ (degrees->radians (ellipse-angle atomic-shape))]
|
[θ (degrees->radians (ellipse-angle np-atomic-shape))]
|
||||||
[color (ellipse-color atomic-shape)]
|
[color (ellipse-color np-atomic-shape)]
|
||||||
[mode (ellipse-mode atomic-shape)])
|
[mode (ellipse-mode np-atomic-shape)])
|
||||||
(let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
|
(let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
|
||||||
(send path ellipse 0 0 ew eh)
|
(send path ellipse 0 0 ew eh)
|
||||||
(send path translate (- (/ ew 2)) (- (/ eh 2)))
|
(send path translate (- (/ ew 2)) (- (/ eh 2)))
|
||||||
|
|
@ -669,26 +712,30 @@ has been moved out).
|
||||||
(send dc set-brush (mode-color->brush mode color))
|
(send dc set-brush (mode-color->brush mode color))
|
||||||
(send dc set-smoothing (mode-color->smoothing mode color))
|
(send dc set-smoothing (mode-color->smoothing mode color))
|
||||||
(send dc draw-path path dx dy)))]
|
(send dc draw-path path dx dy)))]
|
||||||
[(bitmap? atomic-shape)
|
[(flip? np-atomic-shape)
|
||||||
(let ([bm (get-rendered-bitmap atomic-shape)])
|
(let ([bm (get-rendered-bitmap np-atomic-shape)])
|
||||||
(send dc draw-bitmap
|
(send dc draw-bitmap
|
||||||
bm
|
bm
|
||||||
(- dx (/ (send bm get-width) 2))
|
(- dx (/ (send bm get-width) 2))
|
||||||
(- dy (/ (send bm get-height) 2))
|
(- dy (/ (send bm get-height) 2))
|
||||||
'solid
|
'solid
|
||||||
(send the-color-database find-color "black")
|
(send the-color-database find-color "black")
|
||||||
(get-rendered-mask atomic-shape)))]
|
(get-rendered-mask np-atomic-shape)))]
|
||||||
[(text? atomic-shape)
|
[(text? np-atomic-shape)
|
||||||
(let ([θ (degrees->radians (text-angle atomic-shape))]
|
(let ([θ (degrees->radians (text-angle np-atomic-shape))]
|
||||||
[font (send dc get-font)])
|
[font (send dc get-font)])
|
||||||
(send dc set-font (text->font atomic-shape))
|
(send dc set-font (text->font np-atomic-shape))
|
||||||
(send dc set-text-foreground
|
(let ([color (get-color-arg (text-color np-atomic-shape))])
|
||||||
(or (send the-color-database find-color (text-color atomic-shape))
|
(send dc set-text-foreground
|
||||||
(send the-color-database find-color "black")))
|
(cond
|
||||||
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))])
|
[(string? color)
|
||||||
|
(or (send the-color-database find-color color)
|
||||||
|
(send the-color-database find-color "black"))]
|
||||||
|
[else color])))
|
||||||
|
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
|
||||||
(let ([p (- (make-rectangular dx dy)
|
(let ([p (- (make-rectangular dx dy)
|
||||||
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
|
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
|
||||||
(send dc draw-text (text-string atomic-shape)
|
(send dc draw-text (text-string np-atomic-shape)
|
||||||
(real-part p)
|
(real-part p)
|
||||||
(imag-part p)
|
(imag-part p)
|
||||||
#f 0 θ))))]))]))
|
#f 0 θ))))]))]))
|
||||||
|
|
@ -741,43 +788,50 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
|
||||||
(define (get-rendered-bitmap bitmap)
|
(define (get-rendered-bitmap flip-bitmap)
|
||||||
(calc-renered-bitmap bitmap)
|
(calc-rendered-bitmap flip-bitmap)
|
||||||
(bitmap-rendered-bitmap bitmap))
|
(bitmap-rendered-bitmap (flip-shape flip-bitmap)))
|
||||||
|
|
||||||
(define (get-rendered-mask bitmap)
|
(define (get-rendered-mask flip-bitmap)
|
||||||
(calc-renered-bitmap bitmap)
|
(calc-rendered-bitmap flip-bitmap)
|
||||||
(bitmap-rendered-mask bitmap))
|
(bitmap-rendered-mask (flip-shape flip-bitmap)))
|
||||||
|
|
||||||
(define (calc-renered-bitmap bitmap)
|
(define (calc-rendered-bitmap flip-bitmap)
|
||||||
(unless (bitmap-rendered-bitmap bitmap)
|
(let ([bitmap (flip-shape flip-bitmap)])
|
||||||
;; fill in the rendered bitmap with the raw bitmaps.
|
(unless (bitmap-rendered-bitmap bitmap)
|
||||||
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
|
(let ([flipped? (flip-flipped? flip-bitmap)])
|
||||||
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
|
|
||||||
(cond
|
|
||||||
[(and (= 1 (bitmap-x-scale bitmap))
|
|
||||||
(= 1 (bitmap-y-scale bitmap))
|
|
||||||
(= 0 (bitmap-angle bitmap)))
|
|
||||||
;; if there's no scaling or rotation, we can just keep that bitmap.
|
|
||||||
(void)]
|
|
||||||
[(<= (* (bitmap-x-scale bitmap)
|
|
||||||
(bitmap-y-scale bitmap))
|
|
||||||
1)
|
|
||||||
;; since we prefer to rotate big things, we rotate first
|
|
||||||
(do-rotate bitmap)
|
|
||||||
(do-scale bitmap)]
|
|
||||||
[else
|
|
||||||
;; since we prefer to rotate big things, we scale first
|
|
||||||
(do-scale bitmap)
|
|
||||||
(do-rotate bitmap)])))
|
|
||||||
|
|
||||||
(define (do-rotate bitmap)
|
;; fill in the rendered bitmap with the raw bitmaps.
|
||||||
|
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
|
||||||
|
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
|
||||||
|
(cond
|
||||||
|
[(and (= 1 (bitmap-x-scale bitmap))
|
||||||
|
(= 1 (bitmap-y-scale bitmap))
|
||||||
|
(= 0 (bitmap-angle bitmap))
|
||||||
|
(not flipped?))
|
||||||
|
;; if there's no scaling, rotation or flipping, we can just keep that bitmap.
|
||||||
|
(void)]
|
||||||
|
[(<= (* (bitmap-x-scale bitmap)
|
||||||
|
(bitmap-y-scale bitmap))
|
||||||
|
1)
|
||||||
|
;; since we prefer to rotate big things, we rotate first
|
||||||
|
(do-rotate bitmap flipped?)
|
||||||
|
(do-scale bitmap)]
|
||||||
|
[else
|
||||||
|
;; since we prefer to rotate big things, we scale first
|
||||||
|
(do-scale bitmap)
|
||||||
|
(do-rotate bitmap flipped?)])))))
|
||||||
|
|
||||||
|
(define (do-rotate bitmap flip?)
|
||||||
(let ([θ (degrees->radians (bitmap-angle bitmap))])
|
(let ([θ (degrees->radians (bitmap-angle bitmap))])
|
||||||
(let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap)
|
(let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap)
|
||||||
(bitmap-rendered-mask bitmap))])
|
(bitmap-rendered-mask bitmap))])
|
||||||
(let-values ([(rotated-bytes rotated-w rotated-h)
|
(let-values ([(rotated-bytes rotated-w rotated-h)
|
||||||
(rotate-bytes bytes w h θ)])
|
(rotate-bytes bytes w h θ)])
|
||||||
(let* ([bm (bytes->bitmap rotated-bytes rotated-w rotated-h)]
|
(let* ([flipped-bytes (if flip?
|
||||||
|
(flip-bytes rotated-bytes w h)
|
||||||
|
rotated-bytes)]
|
||||||
|
[bm (bytes->bitmap flipped-bytes rotated-w rotated-h)]
|
||||||
[mask (send bm get-loaded-mask)])
|
[mask (send bm get-loaded-mask)])
|
||||||
(set-bitmap-rendered-bitmap! bitmap bm)
|
(set-bitmap-rendered-bitmap! bitmap bm)
|
||||||
(set-bitmap-rendered-mask! bitmap mask))))))
|
(set-bitmap-rendered-mask! bitmap mask))))))
|
||||||
|
|
@ -914,6 +968,43 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
||||||
(send ans set-join (pen-join pen))
|
(send ans set-join (pen-join pen))
|
||||||
ans))
|
ans))
|
||||||
|
|
||||||
|
(define (to-img arg)
|
||||||
|
(cond
|
||||||
|
[(is-a? arg image-snip%) (image-snip->image arg)]
|
||||||
|
[(is-a? arg bitmap%) (bitmap->image arg)]
|
||||||
|
[else arg]))
|
||||||
|
|
||||||
|
(define (image-snip->image is)
|
||||||
|
(let ([bm (send is get-bitmap)])
|
||||||
|
(cond
|
||||||
|
[(not bm)
|
||||||
|
;; this might mean we have a cache-image-snip%
|
||||||
|
;; or it might mean we have a useless snip.
|
||||||
|
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
|
||||||
|
(send is get-size)
|
||||||
|
(values 0 0))])
|
||||||
|
(make-image (make-polygon
|
||||||
|
(list (make-point 0 0)
|
||||||
|
(make-point w 0)
|
||||||
|
(make-point w h)
|
||||||
|
(make-point 0 h))
|
||||||
|
'solid "black")
|
||||||
|
(make-bb w h h)
|
||||||
|
#f))]
|
||||||
|
[else
|
||||||
|
(bitmap->image bm
|
||||||
|
(or (send is get-bitmap-mask)
|
||||||
|
(send bm get-loaded-mask)))])))
|
||||||
|
|
||||||
|
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
|
||||||
|
(let ([w (send bm get-width)]
|
||||||
|
[h (send bm get-height)])
|
||||||
|
(make-image (make-translate (/ w 2)
|
||||||
|
(/ h 2)
|
||||||
|
(make-bitmap bm mask-bm 0 1 1 #f #f))
|
||||||
|
(make-bb w h h)
|
||||||
|
#f)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -939,6 +1030,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
||||||
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale
|
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale
|
||||||
bitmap-rendered-bitmap bitmap-rendered-mask
|
bitmap-rendered-bitmap bitmap-rendered-mask
|
||||||
|
|
||||||
|
make-flip flip? flip-flipped? flip-shape
|
||||||
|
|
||||||
(struct-out color)
|
(struct-out color)
|
||||||
|
|
||||||
degrees->radians
|
degrees->radians
|
||||||
|
|
@ -954,7 +1047,11 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
||||||
|
|
||||||
skip-image-equality-fast-path
|
skip-image-equality-fast-path
|
||||||
|
|
||||||
scale-np-atomic)
|
scale-np-atomic
|
||||||
|
|
||||||
|
to-img
|
||||||
|
bitmap->image
|
||||||
|
image-snip->image)
|
||||||
|
|
||||||
;; method names
|
;; method names
|
||||||
(provide get-shape get-bb get-normalized? get-normalized-shape)
|
(provide get-shape get-bb get-normalized? get-normalized-shape)
|
||||||
|
|
|
||||||
|
|
@ -1,30 +1,27 @@
|
||||||
#lang scheme/gui
|
#lang racket/gui
|
||||||
|
|
||||||
;; min-w, min-h : number -> contract
|
|
||||||
;; determines if the widths and heights are suitable
|
|
||||||
(define (min-w h) (flat-named-contract "draw-button-label-width" (lambda (w) (w . > . (- h (* 2 border-inset))))))
|
|
||||||
(define (min-h w) (flat-named-contract "draw-button-label-height" (lambda (h) (h . > . (* 2 border-inset)))))
|
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[get-left-side-padding (-> number?)]
|
[get-left-side-padding (-> number?)]
|
||||||
[pad-xywh (number? number? (>=/c 0) (>=/c 0) . -> . (values number? number? (>=/c 0) (>=/c 0)))]
|
[pad-xywh (-> number? number? (>=/c 0) (>=/c 0)
|
||||||
|
(values number? number? (>=/c 0) (>=/c 0)))]
|
||||||
[draw-button-label
|
[draw-button-label
|
||||||
(->d ([dc (is-a?/c dc<%>)]
|
(->d ([dc (is-a?/c dc<%>)]
|
||||||
[label (or/c false/c string?)]
|
[label (or/c false/c string?)]
|
||||||
[x number?]
|
[x number?]
|
||||||
[y number?]
|
[y number?]
|
||||||
[w (and/c number? (min-w h))]
|
[w number?]
|
||||||
[h (and/c number? (min-h w))]
|
[h (and/c number? (>=/c (* 2 border-inset)))]
|
||||||
[mouse-over? boolean?]
|
[mouse-over? boolean?]
|
||||||
[grabbed? boolean?]
|
[grabbed? boolean?]
|
||||||
[button-label-font (is-a?/c font%)]
|
[button-label-font (is-a?/c font%)]
|
||||||
[bkg-color (or/c false/c (is-a?/c color%) string?)])
|
[bkg-color (or/c false/c (is-a?/c color%) string?)])
|
||||||
()
|
#:pre-cond
|
||||||
|
(w . > . (- h (* 2 border-inset)))
|
||||||
[result void?])]
|
[result void?])]
|
||||||
|
|
||||||
[calc-button-min-sizes
|
[calc-button-min-sizes
|
||||||
(->* ((is-a?/c dc<%>) string? (is-a?/c font%))
|
(->* ((is-a?/c dc<%>) string?)
|
||||||
()
|
((is-a?/c font%))
|
||||||
(values number? number?))])
|
(values number? number?))])
|
||||||
|
|
||||||
(provide name-message%)
|
(provide name-message%)
|
||||||
|
|
@ -241,7 +238,7 @@
|
||||||
(define mouse-grabbed-color (make-object color% 100 100 100))
|
(define mouse-grabbed-color (make-object color% 100 100 100))
|
||||||
(define grabbed-fg-color (make-object color% 220 220 220))
|
(define grabbed-fg-color (make-object color% 220 220 220))
|
||||||
|
|
||||||
(define (calc-button-min-sizes dc label button-label-font)
|
(define (calc-button-min-sizes dc label [button-label-font (send dc get-font)])
|
||||||
(let-values ([(w h a d) (send dc get-text-extent label button-label-font)])
|
(let-values ([(w h a d) (send dc get-text-extent label button-label-font)])
|
||||||
(let-values ([(px py pw ph) (pad-xywh 0 0 w h)])
|
(let-values ([(px py pw ph) (pad-xywh 0 0 w h)])
|
||||||
(values pw ph))))
|
(values pw ph))))
|
||||||
|
|
|
||||||
|
|
@ -4,8 +4,10 @@
|
||||||
|
|
||||||
|
|
||||||
(provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
|
(provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
|
||||||
|
flip-bytes ;; : bytes int[width] int[height] -> bytes
|
||||||
bitmap->bytes
|
bitmap->bytes
|
||||||
bytes->bitmap)
|
bytes->bitmap
|
||||||
|
linear-transform)
|
||||||
;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
|
;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
|
||||||
;; avoid a dependency on scheme/contract, which pulls in too much
|
;; avoid a dependency on scheme/contract, which pulls in too much
|
||||||
|
|
||||||
|
|
@ -76,6 +78,15 @@ instead of this scaling code, we use the dc<%>'s scaling code.
|
||||||
(send bm set-loaded-mask mask)
|
(send bm set-loaded-mask mask)
|
||||||
bm))
|
bm))
|
||||||
|
|
||||||
|
(define (flip-bytes bmbytes w h)
|
||||||
|
(build-bmbytes
|
||||||
|
w h
|
||||||
|
(λ (x y)
|
||||||
|
(let ([new-x x]
|
||||||
|
[new-y (- h y 1)])
|
||||||
|
(bmbytes-ref/safe bmbytes w h new-x new-y)))))
|
||||||
|
|
||||||
|
#;
|
||||||
(define (rotate-bytes bmbytes w h theta)
|
(define (rotate-bytes bmbytes w h theta)
|
||||||
(let* {[theta-rotation (exp (* i theta))]
|
(let* {[theta-rotation (exp (* i theta))]
|
||||||
[theta-unrotation (make-rectangular (real-part theta-rotation)
|
[theta-unrotation (make-rectangular (real-part theta-rotation)
|
||||||
|
|
@ -105,6 +116,89 @@ instead of this scaling code, we use the dc<%>'s scaling code.
|
||||||
(- (imag-part pre-image))))))
|
(- (imag-part pre-image))))))
|
||||||
new-w
|
new-w
|
||||||
new-h)))
|
new-h)))
|
||||||
|
|
||||||
|
;; linear transform: bytes width height <matrix coodinates> -> (values bytes width height)
|
||||||
|
;; The matrix is read like this:
|
||||||
|
;; +- -+
|
||||||
|
;; | a b |
|
||||||
|
;; | c d |
|
||||||
|
;; +- -+
|
||||||
|
;; The ai, bi, ci, and di are the coordinates of the inverse matrix
|
||||||
|
(define (linear-transform bmbytes w h a b c d)
|
||||||
|
(let-values ([(ai bi ci di)
|
||||||
|
(let ([k (/ (- (* a d) (* b c)))])
|
||||||
|
(values (* k d) (* k (- b))
|
||||||
|
(* k (- c)) (* k a)))])
|
||||||
|
;; mapp : <matrix> complex -> complex
|
||||||
|
;; applies the matrix represented by abcd(as in the picture above) to p
|
||||||
|
(define (mapp a b c d p)
|
||||||
|
(let ([x (real-part p)]
|
||||||
|
[y (imag-part p)])
|
||||||
|
(make-rectangular (+ (* a x) (* b y))
|
||||||
|
(+ (* c x) (* d y)))))
|
||||||
|
(let* {[f-rotation (λ (p) (mapp a b c d p))]
|
||||||
|
[f-unrotation (λ (p) (mapp ai bi ci di p))]
|
||||||
|
[ne (f-rotation w)]
|
||||||
|
[sw (f-rotation (* i (- h)))]
|
||||||
|
[se (f-rotation (make-rectangular w (- h)))]
|
||||||
|
[nw 0]
|
||||||
|
[pts (list ne sw se nw)]
|
||||||
|
[longitudes (map real-part pts)]
|
||||||
|
[latitudes (map imag-part pts)]
|
||||||
|
[east (apply max longitudes)]
|
||||||
|
[west (apply min longitudes)]
|
||||||
|
[nrth (apply max latitudes)]
|
||||||
|
[sth (apply min latitudes)]
|
||||||
|
[new-w (round/e (- east west))]
|
||||||
|
[new-h (round/e (- nrth sth))]}
|
||||||
|
(values (build-bmbytes new-w
|
||||||
|
new-h
|
||||||
|
(λ (x y)
|
||||||
|
(let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]}
|
||||||
|
(interpolate bmbytes w h
|
||||||
|
(real-part pre-image)
|
||||||
|
(- (imag-part pre-image))))))
|
||||||
|
new-w
|
||||||
|
new-h))))
|
||||||
|
|
||||||
|
(define (rotate-bytes bmbytes w h theta)
|
||||||
|
(let* ([theta-rotation (exp (* i theta -1))]
|
||||||
|
[x (real-part theta-rotation)]
|
||||||
|
[y (imag-part theta-rotation)])
|
||||||
|
(linear-transform
|
||||||
|
bmbytes w h
|
||||||
|
x (- y) y x)))
|
||||||
|
|
||||||
|
#;
|
||||||
|
(define (rotate-bytes bmbytes w h theta)
|
||||||
|
(let* {[theta-rotation (exp (* i theta))]
|
||||||
|
[theta-unrotation (make-rectangular (real-part theta-rotation)
|
||||||
|
(- (imag-part theta-rotation)))]
|
||||||
|
[f-rotation (λ (p) (* theta-rotation p))]
|
||||||
|
[f-unrotation (λ (p) (* theta-unrotation p))]
|
||||||
|
[ne (f-rotation w)]
|
||||||
|
[sw (f-rotation (* i (- h)))]
|
||||||
|
[se (f-rotation (make-rectangular w (- h)))]
|
||||||
|
[nw 0]
|
||||||
|
[pts (list ne sw se nw)]
|
||||||
|
[longitudes (map real-part pts)]
|
||||||
|
[latitudes (map imag-part pts)]
|
||||||
|
[east (apply max longitudes)]
|
||||||
|
[west (apply min longitudes)]
|
||||||
|
[nrth (apply max latitudes)]
|
||||||
|
[sth (apply min latitudes)]
|
||||||
|
[new-w (round/e (- east west))]
|
||||||
|
[new-h (round/e (- nrth sth))]}
|
||||||
|
(values (build-bmbytes new-w
|
||||||
|
new-h
|
||||||
|
(λ (x y)
|
||||||
|
(let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]}
|
||||||
|
(interpolate bmbytes w h
|
||||||
|
(real-part pre-image)
|
||||||
|
(- (imag-part pre-image))))))
|
||||||
|
new-w
|
||||||
|
new-h)))
|
||||||
|
|
||||||
;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`?
|
;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`?
|
||||||
;; We consider a pixel's RGB as a point-sample taken from the 'true' image,
|
;; We consider a pixel's RGB as a point-sample taken from the 'true' image,
|
||||||
;; where the RGB is the sample at the *center* of the square covered by the pixel.
|
;; where the RGB is the sample at the *center* of the square covered by the pixel.
|
||||||
|
|
|
||||||
|
|
@ -8,7 +8,7 @@
|
||||||
|
|
||||||
@defclass[name-message% canvas% ()]{
|
@defclass[name-message% canvas% ()]{
|
||||||
|
|
||||||
A @scheme[name-message%] control displays a filename that the user can
|
A @racket[name-message%] control displays a filename that the user can
|
||||||
click to show the filename's path and select one of the enclosing
|
click to show the filename's path and select one of the enclosing
|
||||||
directories. Override the @method[name-message% on-choose-directory]
|
directories. Override the @method[name-message% on-choose-directory]
|
||||||
method to handle the user's selection.
|
method to handle the user's selection.
|
||||||
|
|
@ -16,7 +16,7 @@ method to handle the user's selection.
|
||||||
|
|
||||||
@defconstructor/auto-super[()]{
|
@defconstructor/auto-super[()]{
|
||||||
|
|
||||||
Passes all arguments to @scheme[super-init].}
|
Passes all arguments to @racket[super-init].}
|
||||||
|
|
||||||
|
|
||||||
@defmethod[(on-choose-directory [dir path-string?])
|
@defmethod[(on-choose-directory [dir path-string?])
|
||||||
|
|
@ -42,7 +42,7 @@ Draws the control's current message.}
|
||||||
|
|
||||||
@defmethod[(set-hidden? [hidden? any/c])
|
@defmethod[(set-hidden? [hidden? any/c])
|
||||||
void?]{
|
void?]{
|
||||||
Calling this method with @scheme[#f] causes the name message
|
Calling this method with @racket[#f] causes the name message
|
||||||
to become invisible and to stop responding to mouse movements.
|
to become invisible and to stop responding to mouse movements.
|
||||||
|
|
||||||
Calling it with a true value restores its visibility and
|
Calling it with a true value restores its visibility and
|
||||||
|
|
@ -55,32 +55,32 @@ makes it respond to mouse movements again.}
|
||||||
|
|
||||||
Sets the label for the control.
|
Sets the label for the control.
|
||||||
|
|
||||||
If @scheme[file-name?] is @scheme[#t], @scheme[msg] is treated like a
|
If @racket[file-name?] is @racket[#t], @racket[msg] is treated like a
|
||||||
pathname, and a click on the name-message control creates a popup
|
pathname, and a click on the name-message control creates a popup
|
||||||
menu to open a get-file dialog.
|
menu to open a get-file dialog.
|
||||||
|
|
||||||
If @scheme[file-name?] is @scheme[#f], @scheme[msg] is treated as a
|
If @racket[file-name?] is @racket[#f], @racket[msg] is treated as a
|
||||||
label string. Clicking on the name-message control pops up a dialog
|
label string. Clicking on the name-message control pops up a dialog
|
||||||
saying that there is no file name until the file is saved.}
|
saying that there is no file name until the file is saved.}
|
||||||
|
|
||||||
@defmethod[(set-short-title [short-title? boolean?]) void?]{
|
@defmethod[(set-short-title [short-title? boolean?]) void?]{
|
||||||
Sets the @scheme[short-title?] flag. The flag defaults to @scheme[#f].
|
Sets the @racket[short-title?] flag. The flag defaults to @racket[#f].
|
||||||
|
|
||||||
If the flag is @scheme[#t], then
|
If the flag is @racket[#t], then
|
||||||
the label for the control is simply the string @scheme["/"]. Otherwise,
|
the label for the control is simply the string @racket["/"]. Otherwise,
|
||||||
the label is determined by
|
the label is determined by
|
||||||
the @method[name-message% set-message].
|
the @method[name-message% set-message].
|
||||||
}
|
}
|
||||||
|
|
||||||
@defmethod[(get-background-color) (or/c false/c (is-a/c color%) string?)]{
|
@defmethod[(get-background-color) (or/c #f (is-a/c color%) string?)]{
|
||||||
|
|
||||||
The result of this method is used for the background color
|
The result of this method is used for the background color
|
||||||
when redrawing the name message. If it is @scheme[#f], the
|
when redrawing the name message. If it is @racket[#f], the
|
||||||
OS's default panel background is used.
|
OS's default panel background is used.
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
@defmethod[(set-allow-shrinking [width (or/c false/c number?)]) void?]{
|
@defmethod[(set-allow-shrinking [width (or/c #f number?)]) void?]{
|
||||||
|
|
||||||
When this method receives a number, the name-message will
|
When this method receives a number, the name-message will
|
||||||
then shrink (the number indicates the minimum width the name
|
then shrink (the number indicates the minimum width the name
|
||||||
|
|
@ -99,12 +99,13 @@ Defaultly, the name-message does not allow shrinking.
|
||||||
|
|
||||||
|
|
||||||
@defproc[(calc-button-min-sizes [dc (is-a?/c dc<%>)]
|
@defproc[(calc-button-min-sizes [dc (is-a?/c dc<%>)]
|
||||||
[str string?])
|
[str string?]
|
||||||
|
[font (or/c #f (is-a?/c font%)) #f])
|
||||||
(values real? real?)]{
|
(values real? real?)]{
|
||||||
|
|
||||||
Calculates the minimum width and height of a button label (when drawn
|
Calculates the minimum width and height of a button label (when drawn
|
||||||
with @scheme[draw-button-label]). Returns two values: the width
|
with @racket[draw-button-label]). Returns two values: the width
|
||||||
and height. The @scheme[dc] argument is used for sizing.}
|
and height. The @racket[dc] argument is used for sizing.}
|
||||||
|
|
||||||
|
|
||||||
@defproc[(draw-button-label [dc (is-a?/c dc<%>)]
|
@defproc[(draw-button-label [dc (is-a?/c dc<%>)]
|
||||||
|
|
@ -116,7 +117,7 @@ and height. The @scheme[dc] argument is used for sizing.}
|
||||||
[mouse-over? boolean?]
|
[mouse-over? boolean?]
|
||||||
[grabbed? boolean?]
|
[grabbed? boolean?]
|
||||||
[font (is-a?/c font%)]
|
[font (is-a?/c font%)]
|
||||||
[background (or/c (is-a?/c color%) string? false/c)])
|
[background (or/c (is-a?/c color%) string? #f)])
|
||||||
void?]{
|
void?]{
|
||||||
|
|
||||||
Draws a button label like the one for the @onscreen{(define ...)} and
|
Draws a button label like the one for the @onscreen{(define ...)} and
|
||||||
|
|
@ -124,18 +125,30 @@ filename buttons in the top-left corner of the DrRacket frame. Use
|
||||||
this function to draw similar buttons.
|
this function to draw similar buttons.
|
||||||
|
|
||||||
The basic idea is to create a canvas object whose on-paint method is
|
The basic idea is to create a canvas object whose on-paint method is
|
||||||
overridden to call this function. The @scheme[dc] argument should be
|
overridden to call this function. The @racket[dc] argument should be
|
||||||
canvas's drawing context, and @scheme[str] should be the string to
|
canvas's drawing context, and @racket[str] should be the string to
|
||||||
display on the button. The @scheme[width] and @scheme[height]
|
display on the button. The @racket[width] and @racket[height]
|
||||||
arguments should be the width and height of the button, and the
|
arguments should be the width and height of the button, and the
|
||||||
@scheme[dx] and @scheme[dy] arguments specify an offset into
|
@racket[dx] and @racket[dy] arguments specify an offset into
|
||||||
@scheme[dc] for the button. The @scheme[mouse-over?] argument should
|
@racket[dc] for the button. The @racket[mouse-over?] argument should
|
||||||
be true when the mouse is over the button, and the @scheme[grabbed?]
|
be true when the mouse is over the button, and the @racket[grabbed?]
|
||||||
argument should be true when the button has been pressed. The
|
argument should be true when the button has been pressed. The
|
||||||
@scheme[font] and @scheme[background] arguments supply the font to use
|
@racket[font] and @racket[background] arguments supply the font to use
|
||||||
in drawing (possibly @scheme[normal-control-font]) and the background
|
in drawing (possibly @racket[normal-control-font]) and the background
|
||||||
color to paint (if any).
|
color to paint (if any).
|
||||||
|
|
||||||
See @scheme[calc-button-min-sizes] for help calculating the min sizes
|
See @racket[calc-button-min-sizes] for help calculating the min sizes
|
||||||
of the button.}
|
of the button.}
|
||||||
|
|
||||||
|
@defproc[(pad-xywh [tx number?]
|
||||||
|
[ty number?]
|
||||||
|
[tw (>=/c 0)]
|
||||||
|
[th (>=/c 0)])
|
||||||
|
(values number? number? (>=/c 0) (>=/c 0))]{
|
||||||
|
Returns spacing information describing how
|
||||||
|
@racket[draw-button-label] draws. The inputs are
|
||||||
|
the x and y coordinates where the text should appear
|
||||||
|
and the width and height of the text, and the results
|
||||||
|
are the x and y coordinates where the shape should be
|
||||||
|
drawn and the width and height of the overall shape.
|
||||||
|
}
|
||||||
|
|
@ -1,4 +1,25 @@
|
||||||
#lang scheme/base
|
#lang racket/base
|
||||||
|
(require (except-in mred
|
||||||
|
make-gui-namespace
|
||||||
|
make-gui-empty-namespace))
|
||||||
|
|
||||||
(require mred)
|
(provide (all-from-out mred)
|
||||||
(provide (all-from-out mred))
|
make-gui-namespace
|
||||||
|
make-gui-empty-namespace)
|
||||||
|
|
||||||
|
(define-namespace-anchor anchor)
|
||||||
|
|
||||||
|
(define (make-gui-empty-namespace)
|
||||||
|
(let ([ns (make-base-empty-namespace)])
|
||||||
|
(namespace-attach-module (namespace-anchor->empty-namespace anchor)
|
||||||
|
'racket/gui/base
|
||||||
|
ns)
|
||||||
|
ns))
|
||||||
|
|
||||||
|
(define (make-gui-namespace)
|
||||||
|
(let ([ns (make-gui-empty-namespace)])
|
||||||
|
(parameterize ([current-namespace ns])
|
||||||
|
(namespace-require 'racket/base)
|
||||||
|
(namespace-require 'racket/gui/base)
|
||||||
|
(namespace-require 'racket/class))
|
||||||
|
ns))
|
||||||
|
|
|
||||||
|
|
@ -1,2 +1,25 @@
|
||||||
#lang scheme/private/provider
|
#lang scheme/base
|
||||||
racket/gui/base
|
(require (except-in mred
|
||||||
|
make-gui-namespace
|
||||||
|
make-gui-empty-namespace))
|
||||||
|
|
||||||
|
(provide (all-from-out mred)
|
||||||
|
make-gui-namespace
|
||||||
|
make-gui-empty-namespace)
|
||||||
|
|
||||||
|
(define-namespace-anchor anchor)
|
||||||
|
|
||||||
|
(define (make-gui-empty-namespace)
|
||||||
|
(let ([ns (make-base-empty-namespace)])
|
||||||
|
(namespace-attach-module (namespace-anchor->empty-namespace anchor)
|
||||||
|
'scheme/gui/base
|
||||||
|
ns)
|
||||||
|
ns))
|
||||||
|
|
||||||
|
(define (make-gui-namespace)
|
||||||
|
(let ([ns (make-gui-empty-namespace)])
|
||||||
|
(parameterize ([current-namespace ns])
|
||||||
|
(namespace-require 'scheme/base)
|
||||||
|
(namespace-require 'scheme/gui/base)
|
||||||
|
(namespace-require 'scheme/class))
|
||||||
|
ns))
|
||||||
|
|
|
||||||
|
|
@ -38,13 +38,10 @@
|
||||||
@schemeblock[
|
@schemeblock[
|
||||||
(class ...
|
(class ...
|
||||||
...
|
...
|
||||||
(rename [super-make-root-area-container
|
(define status-panel #f)
|
||||||
make-root-area-container])
|
|
||||||
(field
|
|
||||||
[status-panel #f])
|
|
||||||
(define/override (make-root-area-container cls parent)
|
(define/override (make-root-area-container cls parent)
|
||||||
(set! status-panel
|
(set! status-panel
|
||||||
(super-make-root-area-container vertical-panel% parent))
|
(super make-root-area-container vertical-panel% parent))
|
||||||
(let ([root (make-object cls status-panel)])
|
(let ([root (make-object cls status-panel)])
|
||||||
|
|
||||||
(code:comment "... add other children to status-panel ...")
|
(code:comment "... add other children to status-panel ...")
|
||||||
|
|
|
||||||
|
|
@ -1,24 +1,24 @@
|
||||||
|
|
||||||
(module common scheme/base
|
(module common racket/base
|
||||||
(require scribble/manual
|
(require scribble/manual
|
||||||
scribble/basic
|
scribble/basic
|
||||||
scheme/class
|
racket/class
|
||||||
scheme/contract
|
racket/contract
|
||||||
"blurbs.ss"
|
"blurbs.ss"
|
||||||
(only-in "../reference/mz.ss" AllUnix exnraise))
|
(only-in "../reference/mz.ss" AllUnix exnraise))
|
||||||
(provide (all-from-out scribble/manual)
|
(provide (all-from-out scribble/manual)
|
||||||
(all-from-out scribble/basic)
|
(all-from-out scribble/basic)
|
||||||
(all-from-out scheme/class)
|
(all-from-out racket/class)
|
||||||
(all-from-out scheme/contract)
|
(all-from-out racket/contract)
|
||||||
(all-from-out "blurbs.ss")
|
(all-from-out "blurbs.ss")
|
||||||
(all-from-out "../reference/mz.ss"))
|
(all-from-out "../reference/mz.ss"))
|
||||||
|
|
||||||
(require (for-label scheme/gui/base
|
(require (for-label racket/gui/base
|
||||||
scheme/class
|
racket/class
|
||||||
scheme/contract
|
racket/contract
|
||||||
scheme/base))
|
racket/base))
|
||||||
(provide (for-label (all-from-out scheme/gui/base)
|
(provide (for-label (all-from-out racket/gui/base)
|
||||||
(all-from-out scheme/class)
|
(all-from-out racket/class)
|
||||||
(all-from-out scheme/contract)
|
(all-from-out racket/contract)
|
||||||
(all-from-out scheme/base))))
|
(all-from-out racket/base))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -267,12 +267,12 @@ Strips shortcut ampersands from @racket[label], removes parenthesized
|
||||||
@defproc[(make-gui-empty-namespace) namespace?]{
|
@defproc[(make-gui-empty-namespace) namespace?]{
|
||||||
|
|
||||||
Like @racket[make-base-empty-namespace], but with
|
Like @racket[make-base-empty-namespace], but with
|
||||||
@racket[racket/class] and @racketmodname[racket/gui/base] also
|
@racketmodname[racket/class] and @racketmodname[racket/gui/base] also
|
||||||
attached to the result namespace.}
|
attached to the result namespace.}
|
||||||
|
|
||||||
@defproc[(make-gui-namespace) namespace?]{
|
@defproc[(make-gui-namespace) namespace?]{
|
||||||
|
|
||||||
Like @racket[make-base-namespace], but with @racket[racket/class] and
|
Like @racket[make-base-namespace], but with @racketmodname[racket/class] and
|
||||||
@racketmodname[racket/gui/base] also required into the top-level
|
@racketmodname[racket/gui/base] also required into the top-level
|
||||||
environment of the result namespace.}
|
environment of the result namespace.}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ create a useful snip:
|
||||||
|
|
||||||
@item{@method[snip% split] if the snip can contain more than one @techlink{item}}
|
@item{@method[snip% split] if the snip can contain more than one @techlink{item}}
|
||||||
|
|
||||||
@item{@method[snip% size-cache-invalid] if the snip caches the result to@method[snip% get-extent]}
|
@item{@method[snip% size-cache-invalid] if the snip caches the result to @method[snip% get-extent]}
|
||||||
|
|
||||||
@item{@method[snip% get-text] (not required)}
|
@item{@method[snip% get-text] (not required)}
|
||||||
|
|
||||||
|
|
@ -336,7 +336,12 @@ following symbols:
|
||||||
snip; only an owning editor should set this flag}
|
snip; only an owning editor should set this flag}
|
||||||
|
|
||||||
@item{@indexed-scheme['handles-events] --- this snip can handle
|
@item{@indexed-scheme['handles-events] --- this snip can handle
|
||||||
keyboard and mouse events}
|
keyboard and mouse events when it has the keyboard focus}
|
||||||
|
|
||||||
|
@item{@indexed-scheme['handles-all-mouse-events] --- this snip can
|
||||||
|
handle mouse events that touch the snip or that immediately
|
||||||
|
follow an event that touches the snip, even if the snip does
|
||||||
|
not have the keyboard focus}
|
||||||
|
|
||||||
@item{@indexed-scheme['width-depends-on-x] --- this snip's display
|
@item{@indexed-scheme['width-depends-on-x] --- this snip's display
|
||||||
width depends on the snip's x-@techlink{location} within the
|
width depends on the snip's x-@techlink{location} within the
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,9 @@
|
||||||
|
Version 5.0.1, July 2010
|
||||||
|
|
||||||
|
Minor bug fixes
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
Version 5.0, May 2010
|
Version 5.0, May 2010
|
||||||
|
|
||||||
Changed the executable from MrEd to GRacket
|
Changed the executable from MrEd to GRacket
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user