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

cocoa: fix interaction of combo-field% popup and canvas refresh

Browse Source 
and also reduce work on redundant show/hide of canvas
 Closes PR 11557

original commit: 975c2400a1e994f48938b61dd26aa61738dcda37
This commit is contained in:
Matthew Flatt 2010-12-19 18:58:27 -07:00
commit ec70e25288
45 changed files with 819 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/framework/gui-utils.rkt
View File

@ -111,36 +111,36 @@
(define (cancel-on-right?) (system-position-ok-before-cancel?))
(define ok/cancel-buttons
(lambda (parent
confirm-callback
cancel-callback
[confirm-str (string-constant ok)]
[cancel-str (string-constant cancel)])
(let ([confirm (λ ()
(instantiate button% ()
(parent parent)
(callback confirm-callback)
(label confirm-str)
(style '(border))))]
[cancel (λ ()
(instantiate button% ()
(parent parent)
(callback cancel-callback)
(label cancel-str)))])
(let-values ([(b1 b2)
(cond
[(cancel-on-right?)
(values (confirm) (cancel))]
[else
(values (cancel) (confirm))])])
(let ([w (max (send b1 get-width)
(send b2 get-width))])
(send b1 min-width w)
(send b2 min-width w)
(if (cancel-on-right?)
(values b1 b2)
(values b2 b1)))))))
(define (ok/cancel-buttons parent
confirm-callback
cancel-callback
[confirm-str (string-constant ok)]
[cancel-str (string-constant cancel)]
#:confirm-style [confirm-style '(border)])
(let ([confirm (λ ()
(instantiate button% ()
(parent parent)
(callback confirm-callback)
(label confirm-str)
(style confirm-style)))]
[cancel (λ ()
(instantiate button% ()
(parent parent)
(callback cancel-callback)
(label cancel-str)))])
(let-values ([(b1 b2)
(cond
[(cancel-on-right?)
(values (confirm) (cancel))]
[else
(values (cancel) (confirm))])])
(let ([w (max (send b1 get-width)
(send b2 get-width))])
(send b1 min-width w)
(send b2 min-width w)
(if (cancel-on-right?)
(values b1 b2)
(values b2 b1))))))
(define clickback-delta (make-object style-delta% 'change-underline #t))
@ -346,24 +346,30 @@
((is-a?/c button%) (is-a?/c event%) . -> . any)
((is-a?/c button%) (is-a?/c event%) . -> . any))
(string?
string?)
string?
#:confirm-style (listof symbol?))
(values (is-a?/c button%)
(is-a?/c button%)))
((parent
confirm-callback
cancel-callback)
((confirm-label (string-constant ok))
(cancel-label (string-constant cancel))))
(cancel-label (string-constant cancel))
(confirm-style '(border))))
@{Adds an Ok and a cancel button to a panel, changing the order
to suit the platform. Under Mac OS X and unix, the confirmation action
is on the right (or bottom) and under Windows, the canceling action is on
the right (or bottom).
The confirmation action button has the @scheme['(border)] style.
The buttons are also sized to be the same width.
The first result is be the OK button and the second is
the cancel button.
By default, the confirmation action button has the @scheme['(border)] style,
meaning that hitting return in the dialog will trigger the confirmation action.
The @racket[confirm-style] argument can override this behavior, tho.
See @racket[button%] for the precise list of allowed styles.
See also @scheme[gui-utils:cancel-on-right?].})
(proc-doc/names

19
collects/mred/mred.rkt
View File

@ -4,20 +4,19 @@
namespace-anchor->empty-namespace
make-base-empty-namespace)
scheme/class
racket/draw
racket/draw racket/snip
mzlib/etc
(prefix wx: "private/kernel.ss")
(prefix wx: "private/wxme/style.ss")
(prefix wx: "private/wxme/editor.ss")
(prefix wx: "private/wxme/text.ss")
(prefix wx: "private/wxme/pasteboard.ss")
(prefix wx: "private/wxme/snip.ss")
(prefix wx: "private/wxme/keymap.ss")
(prefix wx: "private/wxme/editor-admin.ss")
(prefix wx: "private/wxme/editor-data.ss")
(prefix wx: "private/wxme/editor-snip.ss")
(prefix wx: "private/wxme/stream.ss")
(prefix wx: "private/wxme/wordbreak.ss")
(prefix wx: "private/wxme/snip-admin.ss")
"private/wxtop.ss"
"private/app.ss"
"private/misc.ss"
@ -68,7 +67,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-eventspace)
(parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
(parameterize ([the-snip-class-list (make-the-snip-class-list)]
[wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
(wx:make-eventspace)))
@ -120,8 +119,6 @@
get-highlight-background-color
get-highlight-text-color
get-the-editor-data-class-list
get-the-snip-class-list
image-snip%
is-busy?
is-color-display?
key-event%
@ -142,19 +139,13 @@
read-editor-global-header
read-editor-version
scroll-event%
snip%
snip-admin%
snip-class%
snip-class-list<%>
special-control-key
special-option-key
map-command-as-meta-key
label->plain-label
string-snip%
style<%>
style-delta%
style-list%
tab-snip%
write-editor-global-footer
write-editor-global-header
write-editor-version
@ -183,7 +174,8 @@
[else ".gracketrc"]))]
[else #f])))
(provide (all-from racket/draw))
(provide (all-from racket/draw)
(all-from racket/snip))
(provide button%
canvas%
@ -274,7 +266,6 @@
view-control-font
menu-control-font
timer%
readable-snip<%>
open-input-text-editor
open-input-graphical-file
open-output-text-editor

57
collects/mred/private/snipfile.rkt
View File

@ -3,67 +3,18 @@
racket/port
syntax/moddep
(prefix-in wx: "kernel.ss")
(prefix-in wx: "wxme/snip.ss")
(prefix-in wx: racket/snip)
(prefix-in wx: "wxme/cycle.ss")
"check.ss"
"editor.ss")
(provide readable-snip<%>
open-input-text-editor
(provide open-input-text-editor
open-input-graphical-file
text-editor-load-handler
open-output-text-editor )
;; snip-class% and editor-data-class% loaders
(define (ok-string-element? m)
(and (string? m)
(regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m)
(not (string=? m ".."))
(not (string=? m "."))))
(define (ok-lib-path? m)
(and (pair? m)
(eq? 'lib (car m))
(pair? (cdr m))
(list? m)
(andmap ok-string-element? (cdr m))))
(let ([load-one
(lambda (str id %)
(let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)])
(and (regexp-match #rx"^[(].*[)]$" str)
(let* ([p (open-input-string str)]
[m (read p)])
(and (eof-object? (read p))
m))))])
(if (or (ok-lib-path? m)
(and (list? m)
(= (length m) 2)
(ok-lib-path? (car m))
(ok-lib-path? (cadr m))))
(let ([m (if (ok-lib-path? m)
m
(car m))])
(let ([result (dynamic-require m id)])
(if (is-a? result %)
result
(error 'load-class "not a ~a% instance" id))))
#f)))])
;; install the getters:
(wx:set-get-snip-class!
(lambda (name)
(load-one name 'snip-class wx:snip-class%)))
(wx:set-get-editor-data-class!
(lambda (name)
(load-one name 'editor-data-class wx:editor-data-class%))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define readable-snip<%>
(interface ()
read-special))
(define empty-string (make-bytes 0))
;; open-input-text-editor : (instanceof text%) num num -> input-port
@ -188,7 +139,7 @@
(next-snip empty-string)
(lambda (file line col ppos)
(if (is-a? the-snip wx:snip%)
(if (is-a? the-snip readable-snip<%>)
(if (is-a? the-snip wx:readable-snip<%>)
(send the-snip read-special file line col ppos)
(send the-snip copy))
the-snip)))]
@ -212,7 +163,7 @@
v)))
close)])
(when lock-while-reading?
(send text begin-edit-sequencce)
(send text begin-edit-sequence)
(send text lock #t))
(if (is-a? snip wx:string-snip%)
;; Special handling for initial snip string in

26
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -245,7 +245,8 @@
client-to-screen
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll)
refresh-for-autoscroll
flush)
(define vscroll-ok? (and (memq 'vscroll style) #t))
(define vscroll? vscroll-ok?)
@ -360,7 +361,7 @@
(tellv content-cocoa setDelegate: content-cocoa)
(install-control-font content-cocoa #f))
(define dc (make-object dc% this))
(define dc (make-object dc% this (memq 'transparent canvas-style)))
(send dc start-backing-retained)
@ -382,6 +383,7 @@
(define/override (get-client-size xb yb)
(super get-client-size xb yb)
(when is-combo?
(set-box! xb (max 0 (- (unbox xb) 22)))
(set-box! yb (max 0 (- (unbox yb) 5)))))
(define/override (maybe-register-as-child parent on?)
@ -396,15 +398,16 @@
(define/override (show on?)
;; FIXME: what if we're in the middle of an on-paint?
(super show on?)
(fix-dc))
(super show on?))
(define/override (hide-children)
(super hide-children)
(fix-dc #f)
(suspend-all-reg-blits))
(define/override (show-children)
(super show-children)
(fix-dc)
(resume-all-reg-blits))
(define/override (fixup-locations-children)
@ -627,6 +630,13 @@
(tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
#t)
(define/public (on-combo-select i) (void))
(define/public (popup-combo)
;; Pending refresh events intefere with combo popups
;; for some reason, so flush them:
(yield-refresh)
(flush)
;; Beware that the `popUp:' method is undocumented:
(tellv (tell content-cocoa cell) popUp: #f))
(define clear-bg? (and (not (memq 'transparent canvas-style))
(not (memq 'no-autoclear canvas-style))))
@ -718,7 +728,7 @@
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
((send e get-x) . > . (- (unbox xb) 22))))
((send e get-x) . > . (unbox xb))))
(define/public (on-popup) (void))
@ -764,12 +774,10 @@
(void))
(define/public (get-backing-size xb yb)
(get-client-size xb yb)
(when is-combo?
(set-box! xb (- (unbox xb) 22))))
(get-client-size xb yb))
(define/override (get-cursor-width-delta)
(if is-combo? 22 0))
0)
(define/public (is-flipped?)
(tell #:type _BOOL (get-cocoa-content) isFlipped))

14
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -23,11 +23,12 @@
(define dc%
(class backing-dc%
(init [(cnvs canvas)])
(init [(cnvs canvas)]
transparent?)
(define canvas cnvs)
(inherit end-delay)
(super-new)
(super-new [transparent? transparent?])
(define gl #f)
(define/override (get-gl-context)
@ -89,13 +90,6 @@
(let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))]
[cr (cairo_create surface)])
(cairo_surface_destroy surface)
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 (unbox w) (unbox h))
(cairo_fill cr)
(cairo_set_source cr s)
(cairo_pattern_destroy s))
(backing-draw-bm bm cr (unbox w) (unbox h))
(cairo_destroy cr))))))
(tellv ctx restoreGraphicsState)))

10
collects/mred/private/wx/cocoa/message.rkt
View File

@ -16,20 +16,14 @@
;; ----------------------------------------
(import-class NSTextField NSImageView NSWorkspace)
(import-class NSTextField NSImageView NSWorkspace NSRunningApplication)
(define _OSType _uint32)
(define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id))
(define (get-app-icon)
(tell (tell NSWorkspace sharedWorkspace)
iconForFile:
(tell (tell (tell NSWorkspace sharedWorkspace)
activeApplication)
objectForKey:
#:type _NSString
"NSApplicationPath")))
(tell (tell NSRunningApplication currentApplication) icon))
(define (make-icon label)
(let ([icon

56
collects/mred/private/wx/common/backing-dc.rkt
View File

@ -4,11 +4,14 @@
racket/draw/private/bitmap-dc
racket/draw/private/bitmap
racket/draw/private/local
racket/draw/private/record-dc
racket/draw/unsafe/cairo
"../../lock.rkt"
"queue.rkt")
(provide
(protect-out backing-dc%
backing-draw-bm
;; scoped method names:
get-backing-size
@ -35,13 +38,19 @@
end-delay)
(define backing-dc%
(class (dc-mixin bitmap-dc-backend%)
(class (record-dc-mixin (dc-mixin bitmap-dc-backend%))
(init transparent?)
(inherit internal-get-bitmap
internal-set-bitmap
reset-cr)
reset-cr
set-recording-limit
get-recorded-command)
(super-new)
(set-recording-limit (if transparent? 1024 -1))
(define/override (ok?) #t)
;; Override this method to get the right size
@ -67,7 +76,8 @@
[(not retained-cr) #f]
[(positive? retained-counter)
(unless nada?
(proc (internal-get-bitmap)))
(proc (or (get-recorded-command)
(internal-get-bitmap))))
#t]
[else
(reset-backing-retained proc)
@ -155,3 +165,43 @@
(define (release-backing-bitmap bm)
(send bm release-bitmap-storage))
(define cairo-dc
(make-object (dc-mixin
(class default-dc-backend%
(inherit reset-cr)
(define cr #f)
(define w 0)
(define h 0)
(super-new)
(define/public (set-cr new-cr new-w new-h)
(set! cr new-cr)
(set! w new-w)
(set! h new-h)
(when cr
(reset-cr cr)))
(define/override (get-cr) cr)
(define/override (reset-clip cr)
(super reset-clip cr)
(cairo_rectangle cr 0 0 w h)
(cairo_clip cr))))))
(define (backing-draw-bm bm cr w h)
(if (procedure? bm)
(begin
(send cairo-dc set-cr cr w h)
(bm cairo-dc)
(send cairo-dc set-cr #f 0 0))
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 w h)
(cairo_fill cr)
(cairo_set_source cr s)
(cairo_pattern_destroy s))))

9
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -143,7 +143,8 @@
(let ([pq paint-queued])
(when pq (set-box! pq #f)))
(set! paint-queued #f)
(when (or (not b) (is-shown-to-root?))
(cond
[(or (not b) (is-shown-to-root?))
(let ([dc (get-dc)])
(send dc suspend-flush)
(send dc ensure-ready)
@ -156,7 +157,11 @@
(send dc set-background old-bg))))
(on-paint)
(send dc resume-flush)
(queue-backing-flush))))
(queue-backing-flush))]
[b ; => not shown to root
;; invalidate dc so that it's refresh
;; when it's shown again
(send (get-dc) reset-backing-retained)]))
(when req
(cancel-canvas-flush-delay req)))

20
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -41,6 +41,7 @@
(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget))
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void))
(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void))
(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
@ -283,7 +284,7 @@
(set-size x y w h)
(define dc (new dc% [canvas this]))
(define dc (new dc% [canvas this] [transparent? (memq 'transparent style)]))
(define for-gl? (memq 'gl style))
(when for-gl?
@ -344,10 +345,19 @@
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
(define/override (internal-pre-on-event gtk e)
(when (and (ptr-equal? gtk combo-button-gtk)
(send e button-down?))
(on-popup))
#f)
(if (and (ptr-equal? gtk combo-button-gtk)
(send e button-down?))
(begin
(on-popup)
#t)
#f))
(define/public (popup-combo)
;; Unfortunately, the user has to hold the mouse
;; button down when popping up the menu this way,
;; whereas the default handler (that we subvert in
;; `internal-pre-on-event') keeps the menu open if
;; the user release the mouse button right away.
(gtk_combo_box_popup gtk))
(define/override (get-client-delta)
(values margin margin))

14
collects/mred/private/wx/gtk/dc.rkt
View File

@ -92,11 +92,12 @@
(define dc%
(class backing-dc%
(init [(cnvs canvas)])
(init [(cnvs canvas)]
transparent?)
(inherit end-delay)
(define canvas cnvs)
(super-new)
(super-new [transparent? transparent?])
(define gl #f)
(define/override (get-gl-context)
@ -146,12 +147,5 @@
[h (box 0)])
(send canvas get-client-size w h)
(let ([cr (gdk_cairo_create win)])
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 (unbox w) (unbox h))
(cairo_fill cr)
(cairo_set_source cr s)
(cairo_pattern_destroy s))
(backing-draw-bm bm cr (unbox w) (unbox h))
(cairo_destroy cr))))))

7
collects/mred/private/wx/win32/canvas.rkt
View File

@ -47,6 +47,8 @@
(define HTHSCROLL 6)
(define HTVSCROLL 7)
(define CB_SHOWDROPDOWN #x014F)
(define-cstruct _SCROLLINFO
([cbSize _UINT]
[fMask _UINT]
@ -202,7 +204,7 @@
(define/override (wndproc-for-ctlproc w msg wParam lParam default)
(default w msg wParam lParam))
(define dc (new dc% [canvas this]))
(define dc (new dc% [canvas this] [transparent? (memq 'transparent style)]))
(send dc start-backing-retained)
(define/public (get-dc) dc)
@ -488,6 +490,9 @@
[(= cmd CBN_DROPDOWN)
(constrained-reply (get-eventspace) (lambda () (on-popup)) (void))]))
(define/public (popup-combo)
(SendMessageW combo-hwnd CB_SHOWDROPDOWN 1 0))
(define/override (is-hwnd? a-hwnd)
(or (ptr-equal? panel-hwnd a-hwnd)
(ptr-equal? canvas-hwnd a-hwnd)

14
collects/mred/private/wx/win32/dc.rkt
View File

@ -63,11 +63,12 @@
(define dc%
(class backing-dc%
(init [(cnvs canvas)])
(init [(cnvs canvas)]
transparent?)
(inherit end-delay)
(define canvas cnvs)
(super-new)
(super-new [transparent? transparent?])
(define gl #f)
(define/override (get-gl-context)
@ -116,14 +117,7 @@
(let* ([surface (cairo_win32_surface_create hdc)]
[cr (cairo_create surface)])
(cairo_surface_destroy surface)
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 (unbox w) (unbox h))
(cairo_fill cr)
(cairo_set_source cr s)
(cairo_pattern_destroy s))
(backing-draw-bm bm cr (unbox w) (unbox h))
(cairo_destroy cr))))))
(define (request-flush-delay canvas)

7
collects/mred/private/wx/win32/panel.rkt
View File

@ -22,16 +22,19 @@
(define children null)
(define/override (register-child child on?)
(let ([now-on? (and (memq child children) #t)])
(let ([on? (and on? #t)]
[now-on? (and (memq child children) #t)])
(unless (eq? on? now-on?)
(unless on?
(when (eq? child mouse-in-child)
(send child send-leaves #f)
(set! mouse-in-child #f)))
(set! children
(if on?
(cons child children)
(remq child children)))
(send child parent-enable (is-enabled-to-root?)))))
(when on?
(send child parent-enable (is-enabled-to-root?))))))
(define/override (internal-enable on?)
(super internal-enable on?)

13
collects/mred/private/wx/win32/window.rkt
View File

@ -601,12 +601,13 @@
(define/public (send-leaves mk)
(set! mouse-in? #f)
(let ([e (mk 'leave)])
(if (eq? (current-thread)
(eventspace-handler-thread eventspace))
(handle-mouse-event (get-client-hwnd) 0 0 e)
(queue-window-event this
(lambda () (dispatch-on-event/sync e))))))
(when mk
(let ([e (mk 'leave)])
(if (eq? (current-thread)
(eventspace-handler-thread eventspace))
(handle-mouse-event (get-client-hwnd) 0 0 e)
(queue-window-event this
(lambda () (dispatch-on-event/sync e)))))))
(define/public (send-child-leaves mk)
#f)

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

@ -8,7 +8,6 @@
(decl text% set-text%!)
(decl pasteboard% set-pasteboard%!)
(decl snip-admin% set-snip-admin%!)
(decl editor-stream-in% set-editor-stream-in%!)
(decl editor-stream-out% set-editor-stream-out%!)
(decl editor-snip% set-editor-snip%!)
@ -18,7 +17,6 @@
(decl extended-text% set-extended-text%!)
(decl extended-pasteboard% set-extended-pasteboard%!)
(decl get-snip-class set-get-snip-class!)
(decl get-editor-data-class set-get-editor-data-class!)
(decl editor-get-file set-editor-get-file!)

3
collects/mred/private/wxme/editor-admin.rkt
View File

@ -1,8 +1,9 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"snip.ss"
racket/snip
"private.ss"
racket/snip/private/private
(only-in "cycle.ss" popup-menu%))
(provide editor-admin%)

1
collects/mred/private/wxme/editor-canvas.rkt
View File

@ -5,6 +5,7 @@
"editor.ss"
"editor-admin.ss"
"private.ss"
racket/snip/private/private
(only-in "cycle.ss" popup-menu%)
(only-in "../helper.ss" queue-window-callback)
"wx.ss")

170
collects/mred/private/wxme/editor-data.rkt Normal file
View File

@ -0,0 +1,170 @@
#lang racket/base
(require scheme/class
scheme/file file/convertible
"../syntax.ss"
racket/snip/private/snip-flags
"private.ss"
racket/snip/private/private
"style.ss"
racket/snip/private/load-one
(only-in "cycle.ss"
editor-stream-in% editor-stream-out%
get-editor-data-class set-get-editor-data-class!)
"../wx/common/event.rkt"
racket/draw)
(provide get-the-editor-data-class-list
editor-data%
editor-data-class%
location-editor-data%
editor-data-class-list<%>
the-editor-data-class-list ;; parameter
make-the-editor-data-class-list
(struct-out editor-data-class-link))
;; ------------------------------------------------------------
(defclass editor-data% object%
(properties [[(make-or-false editor-data-class%) dataclass] #f]
[[(make-or-false editor-data%) next] #f])
(super-new)
(def/public (write [editor-stream-out% f])
(error 'write "should have overridden"))
(define/public (get-s-dataclass) dataclass)
(define/public (get-s-next) next)
(define/public (set-s-next v) (set! next v)))
(defclass location-editor-data% editor-data%
(inherit set-dataclass)
(init-field x y)
(super-new)
(set-dataclass the-location-editor-data-class)
(define/public (get-x) x)
(define/public (get-y) y)
(def/override (write [editor-stream-out% f])
(send f put x)
(send f put y)
#t))
;; ------------------------------------------------------------
(defclass editor-data-class% object%
(define classname "wxbad")
(def/public (set-classname [string? s])
(set! classname (string->immutable-string s)))
(def/public (get-classname) classname)
(properties [[bool? required?] #f])
(define/public (get-s-required?) required?)
(def/public (read [editor-stream-in% f]) (void))
(super-new))
(defclass location-editor-data-class% editor-data-class%
(inherit set-classname
set-required?)
(super-new)
(set-classname "wxloc")
(set-required? #t)
(def/override (read [editor-stream-in% f])
(let ([x (send f get-inexact)]
[y (send f get-inexact)])
(new location-editor-data% [x x][y y]))))
(define the-location-editor-data-class
(new location-editor-data-class%))
;; ------------------------------------------------------------
(define-struct editor-data-class-link ([c #:mutable] [name #:mutable] map-position))
(defclass editor-data-class-list% object%
(define ht (make-hash))
(define pos-ht (make-hash))
(define rev-pos-ht (make-hash))
(super-new)
(add the-location-editor-data-class)
(def/public (find [string? name])
(let ([c (hash-ref ht name #f)])
(or c
(let ([c (get-editor-data-class name)])
(when c (add c))
c))))
(def/public (find-position [editor-data-class% c])
(hash-ref pos-ht c 0))
(def/public (add [editor-data-class% c])
(let ([name (send c get-classname)])
(hash-set! ht name c)
(let ([n (add1 (hash-count pos-ht))])
(hash-set! pos-ht c n)
(hash-set! rev-pos-ht n c))))
(def/public (number) (hash-count ht))
(def/public (nth [exact-nonnegative-integer? n]) (hash-ref rev-pos-ht n #f))
(def/public (write [editor-stream-out% f])
(let ([n (number)])
(send f put n)
(for ([i (in-range 1 (add1 n))])
(let ([c (nth i)])
(send f put (string->bytes/utf-8 (send c get-classname)))
(send f add-dl (make-editor-data-class-link c
#f
i)))))
#t)
(def/public (read [editor-stream-in% f])
(let-boxes ([count 0])
(send f get count)
(for/and ([i (in-range count)])
(let ([s (send f get-bytes)])
(and (send f ok?)
(send f add-dl (make-editor-data-class-link
#f
(bytes->string/utf-8 s #\?)
(add1 i)))
#t)))))
(define/public (find-by-map-position f n)
(ormap (lambda (s)
(and (= n (editor-data-class-link-map-position s))
(begin
(when (editor-data-class-link-name s)
(let ([c (find (editor-data-class-link-name s))])
(when (not c)
;; unknown class/version
(log-error (format "unknown editor data class: ~e"
(editor-data-class-link-name s))))
(set-editor-data-class-link-name! s #f)
(set-editor-data-class-link-c! s c)))
(editor-data-class-link-c s))))
(send f get-dl))))
(define editor-data-class-list<%> (class->interface editor-data-class-list%))
(define (make-the-editor-data-class-list)
(new editor-data-class-list%))
(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list)))
(define (get-the-editor-data-class-list)
(the-editor-data-class-list))
(set-get-editor-data-class!
(lambda (name)
(load-one name 'editor-data-class editor-data-class%)))

76
collects/mred/private/wxme/editor-snip-class.rkt Normal file
View File

@ -0,0 +1,76 @@
#lang racket/base
(require racket/class
racket/file file/convertible
"../syntax.ss"
racket/snip/private/snip-flags
"private.ss"
racket/snip/private/private
"style.ss"
racket/snip
(only-in "cycle.ss"
editor-stream-in% editor-stream-out%
extended-text% extended-pasteboard% extended-editor-snip%
get-editor-data-class)
"../wx/common/event.rkt"
racket/draw)
(provide the-editor-snip-class)
;; ------------------------------------------------------------
(defclass editor-snip-class% snip-class%
(inherit set-classname
set-version)
(inherit-field s-required?)
(super-new)
(set-classname "wxmedia")
(set-version 4)
(set! s-required? #t)
(def/override (read [editor-stream-in% f])
(let ([vers (send f do-reading-version this)])
(let ([ed% (case (send f get-exact)
[(1) extended-text%]
[(2) extended-pasteboard%]
[else #f])]
[border? (positive? (send f get-exact))]
[lm (max 0 (send f get-exact))]
[tm (max 0 (send f get-exact))]
[rm (max 0 (send f get-exact))]
[bm (max 0 (send f get-exact))]
[li (max 0 (send f get-exact))]
[ti (max 0 (send f get-exact))]
[ri (max 0 (send f get-exact))]
[bi (max 0 (send f get-exact))]
[min-w (send f get-inexact)]
[max-w (send f get-inexact)]
[min-h (send f get-inexact)]
[max-h (send f get-inexact)]
[tf? (and (vers . > . 1)
(positive? (send f get-exact)))]
[atl? (and (vers . > . 2)
(positive? (send f get-exact)))]
[ubs? (and (vers . > . 3)
(positive? (send f get-exact)))])
(let ([e (and ed% (new ed%))])
(let ([snip (make-object extended-editor-snip%
e
border?
lm tm rm bm li ti ri bi
(if (negative? min-w) 'none min-w)
(if (negative? max-w) 'none max-w)
(if (negative? min-h) 'none min-h)
(if (negative? max-h) 'none max-h))])
(send snip do-set-graphics tf? atl? ubs?)
(if e
(begin
(send e get-style-list)
(send e read-from-file f #t))
(send snip set-editor #f))
snip))))))
(define the-editor-snip-class (new editor-snip-class%))
(send (get-the-snip-class-list) add the-editor-snip-class)

15
collects/mred/private/wxme/editor-snip.rkt
View File

@ -2,12 +2,14 @@
(require scheme/class
"../syntax.ss"
"private.ss"
racket/snip/private/private
"const.ss"
"snip.ss"
"snip-flags.ss"
racket/snip
racket/snip/private/snip-flags
"standard-snip-admin.rkt"
"editor.ss"
"editor-admin.ss"
"snip-admin.ss"
"editor-snip-class.rkt"
"text.ss"
"pasteboard.ss"
"wx.ss"
@ -15,8 +17,7 @@
text%
pasteboard%
editor-snip%
editor-snip-editor-admin%
snip-admin%))
editor-snip-editor-admin%))
(provide editor-snip%
editor-snip-editor-admin<%>)
@ -360,8 +361,8 @@
(when with-border?
(let ([pen (send dc get-pen)])
(when (and (pair? caret)
selected-text-color)
(send dc set-pen selected-text-color 1 'solid))
(send my-admin get-selected-text-color))
(send dc set-pen (send my-admin get-selected-text-color) 1 'solid))
(let* ([l (+ orig-x left-inset)]
[t (+ orig-y top-inset)]
[r (+ l w left-margin right-margin

6
collects/mred/private/wxme/editor.rkt
View File

@ -4,13 +4,15 @@
scheme/file
"../syntax.ss"
"private.ss"
racket/snip/private/private
"style.ss"
"snip.ss"
"snip-flags.ss"
racket/snip
racket/snip/private/snip-flags
"editor-admin.ss"
"stream.ss"
"undo.ss"
"keymap.ss"
"editor-data.rkt"
(only-in "cycle.ss"
text%
pasteboard%

7
collects/mred/private/wxme/mline.rkt
View File

@ -2,9 +2,10 @@
(require scheme/class
"../syntax.ss"
"const.ss"
"snip.ss"
"snip-flags.ss"
"private.ss")
racket/snip
racket/snip/private/snip-flags
"private.ss"
racket/snip/private/private)
(provide create-mline
(struct-out mline)

8
collects/mred/private/wxme/pasteboard.rkt
View File

@ -5,12 +5,14 @@
"../syntax.ss"
"const.ss"
"private.ss"
racket/snip/private/private
"editor.ss"
"editor-data.rkt"
"undo.ss"
"style.ss"
"snip.ss"
"snip-flags.ss"
"snip-admin.ss"
racket/snip
racket/snip/private/snip-flags
"standard-snip-admin.rkt"
"keymap.ss"
(only-in "cycle.ss" set-pasteboard%!)
"wordbreak.ss"

52
collects/mred/private/wxme/private.rkt
View File

@ -3,44 +3,11 @@
(provide (all-defined-out))
;; snip% and editor%
(define-local-member-name
s-admin)
;; snip%
(define-local-member-name
s-prev set-s-prev
s-next set-s-next
s-count
s-style set-s-style
s-line set-s-line
s-snipclass set-s-snipclass
s-flags set-s-flags
s-dtext get-s-dtext
s-buffer get-s-buffer
str-w set-str-w
s-set-flags
do-copy-to)
;; string-snip%
(define-local-member-name
insert-with-offset)
;; snip-class%
(define-local-member-name
get-s-required?
s-read)
;; editor-data%
(define-local-member-name
get-s-dataclass
get-s-next)
;; standard-snip-class-list%, editor-data-class-list%
(define-local-member-name
reset-header-flags
find-by-map-position)
;; editor%
(define-local-member-name
s-offscreen
@ -111,25 +78,6 @@
do-get-canvas
do-scroll-to)
;; editor-stream%
(define-local-member-name
get-sl
get-dl
set-sl
set-dl
add-sl
add-dl
set-s-sll
get-s-sll
get-s-scl
get-s-bdl
get-s-style-count
set-s-style-count
do-reading-version
do-map-position
do-get-header-flag
do-set-header-flag)
;; editor-stream-in%
(define-local-member-name
set-s-read-format

74
collects/mred/private/wxme/snip-admin.rkt → collects/mred/private/wxme/standard-snip-admin.rkt
View File

@ -1,56 +1,15 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"snip.ss"
racket/snip
(only-in "cycle.ss"
set-snip-admin%!
popup-menu%)
"wx.ss")
(prefix-in wx: "wx.ss"))
(provide snip-admin%
standard-snip-admin%)
(provide standard-snip-admin%)
(defclass snip-admin% object%
(super-new)
(define TAB-WIDTH 20)
(def/public (get-editor) #f)
(def/public (get-dc) #f)
(def/public (get-view-size [maybe-box? w] [maybe-box? h])
#f)
(def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h]
[(make-or-false snip%) [snip #f]])
#f)
(def/public (scroll-to [snip% s]
[real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h]
[any? refresh?]
[(symbol-in start end none) [bias 'none]])
#f)
(def/public (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist])
(void))
(def/public (resized [snip% s] [any? redraw?]) (void))
(def/public (recounted [snip% s] [any? redraw?]) (void))
(def/public (needs-update [snip% s] [real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h])
(void))
(def/public (release-snip [snip% s]) #f)
(def/public (update-cursor) (void))
(def/public (popup-menu [popup-menu% p][snip% snip][real? x][real? y])
#f)
(def/public (modified [snip% s] [any? modified?])
(void)))
(set-snip-admin%! snip-admin%)
(defclass standard-snip-admin% snip-admin%
(init-field editor)
@ -146,4 +105,27 @@
(def/override (modified [snip% s] [any? modified?])
(when (eq? (send s get-admin) this)
(send editor on-snip-modified s modified?))))
(send editor on-snip-modified s modified?)))
(def/override (get-line-spacing)
(if (object-method-arity-includes? editor 'get-line-spacing 0)
(send editor get-line-spacing)
0))
(def/override (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]])
(if (object-method-arity-includes? editor 'get-tabs 3)
(send editor get-tabs length tab-width in-units)
(begin (when length (set-box! length 0))
(when tab-width (set-box! tab-width TAB-WIDTH))
(when in-units (set-box! in-units #t))
null)))
(def/override (get-selected-text-color)
(wx:get-highlight-text-color))
(def/override (call-with-busy-cursor [procedure? thunk])
(dynamic-wind
wx:begin-busy-cursor
thunk
wx:end-busy-cursor))
)

4
collects/mred/private/wxme/stream.rkt
View File

@ -2,7 +2,9 @@
(require scheme/class
"../syntax.ss"
"private.ss"
"snip.ss"
racket/snip/private/private
racket/snip
"editor-data.rkt"
(only-in "cycle.ss"
set-editor-stream-in%!
set-editor-stream-out%!))

29
collects/mred/private/wxme/text.rkt
View File

@ -7,12 +7,14 @@
"const.ss"
"mline.ss"
"private.ss"
racket/snip/private/private
"editor.ss"
"editor-data.rkt"
"undo.ss"
"style.ss"
"snip.ss"
"snip-flags.ss"
"snip-admin.ss"
racket/snip
racket/snip/private/snip-flags
"standard-snip-admin.rkt"
"keymap.ss"
(only-in "cycle.ss" set-text%!)
"wordbreak.ss"
@ -5106,7 +5108,22 @@
(lambda ()
(call-on-paint #f)
(set! write-locked? wl?)
(set! flow-locked? #f))])
(set! flow-locked? #f))]
[local-caret-pen
(if bg-color
(let ([r (send bg-color red)]
[g (send bg-color green)]
[b (send bg-color blue)])
(if (and (= r 255) (= g 255) (= b 255))
caret-pen
(make-object pen% (make-object color%
(- 255 r)
(- 255 g)
(- 255 b))
(send caret-pen get-width)
'solid)))
caret-pen)])
(call-on-paint #t)
@ -5132,7 +5149,7 @@
hilite-on?)
(let ([y ycounter]
[save-pen (send dc get-pen)])
(send dc set-pen caret-pen)
(send dc set-pen local-caret-pen)
(send dc draw-line dx (+ y dy) dx (sub1 (+ y extra-line-h dy)))
(send dc set-pen save-pen)))
(paint-done)]
@ -5312,7 +5329,7 @@
(when (eq? 'show-caret show-caret)
(when (and (hsxs . <= . rightx) (hsxs . >= . leftx))
(let ([save-pen (send dc get-pen)])
(send dc set-pen caret-pen)
(send dc set-pen local-caret-pen)
(send dc draw-line (+ hsxs dx) (+ hsys dy)
(+ hsxs dx)
(+ hsye (sub1 dy)))

5
collects/mred/private/wxme/undo.rkt
View File

@ -1,8 +1,9 @@
#lang scheme/base
(require scheme/class
"private.ss"
"snip.ss"
"snip-flags.ss")
racket/snip/private/private
racket/snip
racket/snip/private/snip-flags)
(provide change-record%
proc-record%

14
collects/mred/private/wxme/wx.rkt
View File

@ -1,22 +1,14 @@
#lang scheme/base
(require "../kernel.ss")
(require "../kernel.ss" "symbol-predicates.rkt")
(define the-clipboard (get-the-clipboard))
(define the-x-selection-clipboard (get-the-x-selection))
(define (family-symbol? s)
(memq s '(default decorative roman script
swiss modern symbol system)))
(define (style-symbol? s)
(memq s '(normal italic slant)))
(define (weight-symbol? s)
(memq s '(normal bold light)))
(define (smoothing-symbol? s)
(memq s '(default smoothed unsmoothed partly-smoothed)))
(define (size? v) (and (exact-positive-integer? v)
(byte? v)))
(provide event%
(provide (all-from-out "symbol-predicates.rkt")
event%
mouse-event%
key-event%
timer%

28
collects/mred/private/wxtextfield.rkt
View File

@ -3,7 +3,7 @@
mzlib/class100
(prefix-in wx: "kernel.ss")
(prefix-in wx: "wxme/text.ss")
(prefix-in wx: "wxme/snip.ss")
(prefix-in wx: racket/snip)
(prefix-in wx: "wxme/editor-canvas.ss")
"lock.ss"
"const.ss"
@ -221,6 +221,7 @@
(private-field
[l (and label
(make-object wx-message% #f proxy p label -1 -1 null font))]
[combo-callback #f]
[c (make-object (class wx-text-editor-canvas%
(define/override (on-combo-select i)
(let ([len (length callbacks)])
@ -239,8 +240,31 @@
'(hide-hscroll))
'(hide-vscroll hide-hscroll))))]
[callbacks null])
(override
[pre-on-event (lambda (w e)
(or (super pre-on-event w e)
(and combo-callback
(eq? w c)
(send e button-down?)
(let ([w (box 0)]
[h (box 0)])
(send c get-client-size w h)
(not (and (<= 0 (send e get-x) (unbox w))
(<= 0 (send e get-y) (unbox h)))))
(begin
(do-popup-callback)
#t))))])
(private
[do-popup-callback (lambda ()
(wx:queue-callback (lambda ()
(when (send c is-enabled-to-root?)
(combo-callback)
(send c popup-combo)))
wx:middle-queue-key))])
(public
[set-on-popup (lambda (proc) (send c set-on-popup proc))]
[set-on-popup (lambda (proc)
(set! combo-callback proc)
(send c set-on-popup (lambda () (do-popup-callback))))]
[clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))]
[append-combo-item (lambda (s cb)
(and (send c append-combo-item s)

3
collects/mrlib/cache-image-snip.rkt
View File

@ -1,5 +1,6 @@
(module cache-image-snip mzscheme
(require mred
(require racket/draw
racket/snip
mzlib/class
mzlib/string
mzlib/contract

46
collects/mrlib/image-core.rkt
View File

@ -28,15 +28,17 @@ has been moved out).
|#
(require racket/class
racket/gui/base
racket/draw
(for-syntax racket/base)
file/convertible
racket/math
racket/contract
"private/image-core-bitmap.ss"
"private/image-core-bitmap.ss"
"image-core-wxme.ss"
"private/image-core-snipclass.rkt"
"private/regmk.rkt"
(prefix-in cis: "cache-image-snip.ss")
(for-syntax racket/base))
racket/snip
(prefix-in cis: "cache-image-snip.ss"))
@ -197,8 +199,31 @@ has been moved out).
(define skip-image-equality-fast-path (make-parameter #f))
(define render-normalized (make-parameter #f))
(define png-convertible<%>
(interface* ()
([prop:convertible
(lambda (img format default)
(case format
[(png-bytes)
(let ([s (open-output-bytes)])
(send (to-bitmap (to-img img)) save-file s 'png)
(get-output-bytes s))]
[else default]))])))
(define (to-bitmap img)
(let* ([bb (send img get-bb)]
[bm (make-bitmap
(add1 (inexact->exact (ceiling (bb-right bb))))
(add1 (inexact->exact (ceiling (bb-bottom bb)))))]
[bdc (new bitmap-dc% [bitmap bm])])
(send bdc clear)
(render-image img bdc 0 0)
(begin0
(send bdc get-bitmap)
(send bdc set-bitmap #f))))
(define image%
(class* snip% (equal<%> image<%>)
(class* snip% (png-convertible<%> equal<%> image<%>)
(init-field shape bb normalized? pinhole)
(define/public (equal-to? that eq-recur)
(or (eq? this that)
@ -260,10 +285,7 @@ has been moved out).
(when standard
(let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))])
(let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))])
(set! scroll-step (+ h
(if (is-a? ed text%)
(send ed get-line-spacing)
0)))))))))
(set! scroll-step (+ h (send admin get-line-spacing)))))))))
;; if that didn't happen, set it to 12.
(unless scroll-step (set! scroll-step 12))))
@ -280,8 +302,7 @@ has been moved out).
(define/override (copy) (make-image shape bb normalized? pinhole))
(define/override (draw dc x y left top right bottom dx dy draw-caret?)
(let ([smoothing (send dc get-smoothing)])
(render-image this dc x y)))
(render-image this dc x y))
(define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
(send (get-the-snip-class-list) add snip-class)
@ -1146,7 +1167,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
to-img
bitmap->image
image-snip->image)
image-snip->image
image-snip%)
;; method names
(provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)

2
collects/mrlib/private/image-core-bitmap.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/gui/base
(require racket/draw
scheme/class)

3
collects/mrlib/switchable-button.rkt
View File

@ -88,7 +88,8 @@
(define/override (on-superwindow-show show?)
(unless show?
(set! in? #f)
(set! down? #f))
(set! down? #f)
(refresh))
(super on-superwindow-show show?))
(define/override (on-event evt)

5
collects/scribblings/gui/canvas-class.scrbl
View File

@ -55,8 +55,9 @@ The @scheme[style] argument indicates one or more of the following styles:
canvas before calls to @method[canvas% on-paint]}
@item{@scheme['transparent] --- the canvas is automatically ``erased''
before an update using it's parent window's background; the result is
undefined if this flag is combined with @scheme['no-autoclear]}
before an update using it's parent window's background; see @racket[canvas<%>]
for information on the interaction of @racket['transparent] and offscreen buffering;
the result is undefined if this flag is combined with @scheme['no-autoclear]}
@item{@scheme['no-focus] --- prevents the canvas from accepting the
keyboard focus when the canvas is clicked, or when the

42
collects/scribblings/gui/canvas-intf.scrbl
View File

@ -6,9 +6,6 @@
A canvas is a subwindow onto which graphics and text can be drawn. Canvases also
receive mouse and keyboard events.
To draw onto a canvas, get its device context (see
@method[canvas<%> get-dc]).
The @scheme[canvas<%>] interface is implemented by two classes:
@itemize[
@ -20,6 +17,28 @@ The @scheme[canvas<%>] interface is implemented by two classes:
]
To draw onto a canvas, get its device context (see
@method[canvas<%> get-dc]).
Drawing to a canvas's drawing context actually renders into an
offscreen buffer. The buffer is automatically flushed to the screen by
a background thread, explicitly via the @method[canvas<%> flush]
method, or explicitly via @racket[flush-display]---unless flushing
has been disabled for the canvas. The @method[canvas<%>
suspend-flush] method suspends flushing for a canvas until a matching
@method[canvas<%> resume-flush] calls; calls to @method[canvas<%>
suspend-flush] and @method[canvas<%> resume-flush] can be nested, in
which case flushing is suspended until the outermost @method[canvas<%>
suspend-flush] is balanced by a @method[canvas<%> resume-flush].
In the case of a transparent canvas (i.e., one that is created with
@racket['transparent] style), line and text smoothing can depend on
the window that serves as the canvas's background. For example,
smoothing may color pixels differently depending on whether the target
context is white or gray. Background-sensitive smoothing is supported
only if a relatively small number of drawing commands are recorded in
the canvas's offscreen buffer, however.
@defmethod*[([(accept-tab-focus)
boolean?]
@ -191,7 +210,7 @@ Does nothing.
@defmethod[(resume-flush) void?]{
See @method[canvas<%> suspend-flush].}
See @racket[canvas<%>] for information on canvas flushing.}
@ -223,19 +242,10 @@ Under Mac OS X, enables or disables space for a resize tab at the
@defmethod[(suspend-flush) void?]{
Drawing to a canvas's drawing context actually renders into an
offscreen buffer. The buffer is automatically flushed to the screen by
a background thread, explicitly via the @method[canvas<%> flush] method,
or explicitly via @racket[flush-display] --- unless flushing has been disabled for the canvas.
The @method[canvas<%> suspend-flush] method suspends flushing for a
canvas until a matching @method[canvas<%> resume-flush] calls; calls to
@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] can
be nested, in which case flushing is suspended until the outermost
@method[canvas<%> suspend-flush] is balanced by a @method[canvas<%>
resume-flush].
See @racket[canvas<%>] for information on canvas flushing.
On some platforms, beware that suspending flushing for a canvas can
discourage refreshes for other windows in the same frame.}
Beware that suspending flushing for a canvas can discourage refreshes
for other windows in the same frame on some platforms.}
@defmethod[(warp-pointer [x (integer-in 0 10000)]

27
collects/scribblings/gui/diagrams.rkt
View File

@ -11,8 +11,10 @@
menu-diagram
editor-diagram
snip-diagram
editor-snip-diagram
style-diagram
admin-diagram
snip-list-diagram
editor-admin-diagram
stream-diagram)
(define (diagram->table d)
@ -125,11 +127,21 @@ DIAG
|- string-snip%
| |- tab-snip%
|- image-snip%
|- editor-snip% (not provided by racket/snip)
snip-admin%
DIAG
)
(define editor-snip-diagram
#<<DIAG
snip%
|- editor-snip%
DIAG
)
(define admin-diagram
(define editor-admin-diagram
#<<DIAG
editor-canvas%
@ -145,13 +157,20 @@ DIAG
style<%> style-delta% add-color<%>
style-list% mult-color<%>
DIAG
)
(define snip-list-diagram
#<<DIAG
snip-class%
snip-class-list<%>
DIAG
)
(define stream-diagram
#<<DIAG
editor-data%
editor-data-class% snip-class%
editor-data-class-list<%> snip-class-list<%>
editor-data-class%
editor-data-class-list<%>
editor-stream-in% editor-stream-out%
editor-stream-in-base% editor-stream-out-base%

4
collects/scribblings/gui/editor-canvas-class.scrbl
View File

@ -71,7 +71,9 @@ The @scheme[style] list can contain the following flags:
method}
@item{@scheme['transparent] --- the canvas is ``erased'' before an
update using its parent window's background}
update using its parent window's background; see @racket[canvas<%>]
for information on the interaction of @racket['transparent] and
offscreen buffering}
]

14
collects/scribblings/gui/editor-classes.scrbl
View File

@ -8,13 +8,13 @@ Editors:
@diagram->table[editor-diagram]
Snips:
Editor Snips:
@diagram->table[snip-diagram]
@diagram->table[editor-snip-diagram]
Displays, Administrators, and Mappings:
@diagram->table[admin-diagram]
@diagram->table[editor-admin-diagram]
Styles:
@ -44,18 +44,10 @@ Alphabetical:
@include-section["editor-stream-out-base-class.scrbl"]
@include-section["editor-stream-out-bytes-base-class.scrbl"]
@include-section["editor-wordbreak-map-class.scrbl"]
@include-section["image-snip-class.scrbl"]
@include-section["keymap-class.scrbl"]
@include-section["mult-color-intf.scrbl"]
@include-section["pasteboard-class.scrbl"]
@include-section["readable-snip-intf.scrbl"]
@include-section["snip-class.scrbl"]
@include-section["snip-admin-class.scrbl"]
@include-section["snip-class-class.scrbl"]
@include-section["snip-class-list-intf.scrbl"]
@include-section["string-snip-class.scrbl"]
@include-section["style-intf.scrbl"]
@include-section["style-delta-class.scrbl"]
@include-section["style-list-class.scrbl"]
@include-section["tab-snip-class.scrbl"]
@include-section["text-class.scrbl"]

1
collects/scribblings/gui/gui.scrbl
View File

@ -43,6 +43,7 @@ Both parts of the toolbox rely extensively on the
@include-section["win-classes.scrbl"]
@include-section["win-funcs.scrbl"]
@include-section["editor-overview.scrbl"]
@include-section["snip-classes.scrbl"]
@include-section["editor-classes.scrbl"]
@include-section["editor-funcs.scrbl"]
@include-section["wxme.scrbl"]

68
collects/scribblings/gui/snip-admin-class.scrbl
View File

@ -320,4 +320,70 @@ Queues an update for the cursor in the @techlink{display} for this
Does nothing.
}}}
}}
@defmethod[(get-line-spacing)
(and/c real? (not/c negative?))]{
@methspec{
Returns the spacing inserted by the snip's editor between each
line.
}
@methimpl{
Returns @scheme[0.0]
}}
@defmethod[(get-selected-text-color)
void?]{
@methspec{
Returns the color that is used to draw selected text or @scheme[#f] if
selected text is drawn with its usual color.
}
@methimpl{
Returns @scheme[#f].
}}
@defmethod[(call-with-busy-cursor [thunk (-> any)])
any]{
@methspec{
Calls @scheme[thunk] while changing the cursor to a watch cursor for
all windows in the current eventspace.
}
@methimpl{
Does nothing.
}}
@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) #f) #f]
[tab-width (or/c (box/c real?) #f) #f]
[in-units (or/c (box/c any/c) #f) #f])
(listof real?)]{
@methspec{
Returns the current tab-position array as a list.
@boxisfillnull[(scheme length) @elem{the length of the tab array (and therefore the returned
list)}]
@boxisfillnull[(scheme tab-width) @elem{the width used for tabs past the
end of the tab array}]
@boxisfillnull[(scheme in-units) @elem{@scheme[#t] if the tabs are specified in
canvas units or @scheme[#f] if they are specified in space-widths}]
}
@methimpl{
Returns @scheme[null].
}
}
}

32
collects/scribblings/gui/snip-classes.scrbl Normal file
View File

@ -0,0 +1,32 @@
#lang scribble/doc
@(require "common.ss"
"diagrams.ss")
@title[#:style '(toc quiet)]{Snip Classes}
@;@defmodule*/no-declare[(racket/snip)]
The @racketmodname[racket/snip] collection provides access to the
@tech{snip} classes @emph{without} depending on
@racketmodname[racket/gui].
Snips and Administrators:
@diagram->table[snip-diagram]
Snip Lists:
@diagram->table[snip-list-diagram]
Alphabetical:
@local-table-of-contents[]
@include-section["image-snip-class.scrbl"]
@include-section["readable-snip-intf.scrbl"]
@include-section["snip-class.scrbl"]
@include-section["snip-admin-class.scrbl"]
@include-section["snip-class-class.scrbl"]
@include-section["snip-class-list-intf.scrbl"]
@include-section["string-snip-class.scrbl"]
@include-section["tab-snip-class.scrbl"]

82
collects/tests/gracket/dc.rktl
View File

@ -218,6 +218,88 @@
(send bm3 get-argb-pixels 0 0 70 70 s3)
(test #t 'same-scaled (equal? s2 s3))))
;; ----------------------------------------
;; Test some masking combinations
(let ()
(define u (make-object bitmap% 2 2))
(define mu (make-object bitmap% 2 2))
(send u set-argb-pixels 0 0 2 2
(bytes 255 100 0 0
255 0 0 0
255 100 0 0
255 255 255 255))
(send mu set-argb-pixels 0 0 2 2
(bytes 255 0 0 0
255 255 255 255
255 0 0 0
255 255 255 255))
(send u set-loaded-mask mu)
(define (try-draw nonce-color mode expect
#:bottom? [bottom? #f])
(let* ((b&w? (not (eq? mode 'color)))
(bm (make-object bitmap% 2 2 b&w?))
(dc (make-object bitmap-dc% bm)))
(send dc clear)
(when (eq? mode 'black)
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 0 0 2 2))
;; Check that draw-bitmap-section really uses the
;; section, even in combination with a mask.
(send dc draw-bitmap-section u
0 (if bottom? 1 0)
0 (if bottom? 1 0) 2 1
'solid nonce-color (send u get-loaded-mask))
(send dc set-bitmap #f)
(let ([s (make-bytes (* 2 2 4))])
(send bm get-argb-pixels 0 0 2 2 s)
(when b&w? (send bm get-argb-pixels 0 0 2 2 s #t))
(test expect 'masked-draw s))))
(define usual-expect (bytes 255 100 0 0
255 255 255 255
255 255 255 255
255 255 255 255))
(try-draw (make-object color% "green") 'color usual-expect)
(try-draw (make-object color%) 'color usual-expect)
(try-draw (make-object color%) 'white
;; For b&w destination, check that the
;; alpha is consistent with the drawn pixels
(bytes 255 0 0 0
0 255 255 255
0 255 255 255
0 255 255 255))
(send mu set-argb-pixels 0 0 2 2
(bytes 255 255 255 255
255 255 255 255
255 0 0 0
255 0 0 0))
(try-draw (make-object color%) 'black
#:bottom? #t
;; Another b&w destination test, this time
;; with a mask that forces black pixels to
;; white:
(bytes 255 0 0 0
255 0 0 0
255 0 0 0
0 255 255 255))
(send mu set-argb-pixels 0 0 2 2
(bytes 255 255 255 255
255 0 0 0
255 255 255 255
255 0 0 0))
(try-draw (make-object color%) 'color
(bytes 255 255 255 255
255 0 0 0
255 255 255 255
255 255 255 255))
(let ([dc (make-object bitmap-dc% mu)])
(send dc erase)
(send dc set-pen "white" 1 'transparent)
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 0 0 1 1)
(send dc set-bitmap #f))
(try-draw (make-object color%) 'color usual-expect))
;; ----------------------------------------
(report-errs)

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

@ -660,7 +660,9 @@
; Bitmap copying:
(when (and (not no-bitmaps?) last?)
(let ([x 5] [y 165])
(let ([mred-icon (get-icon)])
(let ([bg (send dc get-background)]
[mred-icon (get-icon)])
(send dc set-background "YELLOW")
(case mask-ex-mode
[(plt plt-mask plt^plt mred^plt)
(let* ([plt (get-plt)]
@ -711,19 +713,20 @@
mred-icon)]
[(mred~)
(send dc draw-bitmap (get-rotated) x y 'opaque)]
[(mred^mred~ opaque-mred^mred~ red-mred^mred~)
[(mred^mred~ opaque-mred^mred~ red-mred^mred~ opaque-red-mred^mred~)
(send dc draw-bitmap mred-icon x y
(if (eq? mask-ex-mode 'opaque-mred^mred~)
(if (memq mask-ex-mode '(opaque-mred^mred~ opaque-red-mred^mred~))
'opaque
'solid)
(send the-color-database find-color
(if (eq? mask-ex-mode 'red-mred^mred~)
(if (memq mask-ex-mode '(red-mred^mred~ opaque-red-mred^mred~))
"RED"
"BLACK"))
(get-rotated))]
[else
;; simple draw
(send dc draw-bitmap mred-icon x y 'xor)]))
(send dc draw-bitmap mred-icon x y 'xor)])
(send dc set-background bg))
(set! x (+ x (send (get-icon) get-width)))
(let ([black (send the-color-database find-color "BLACK")]
[red (send the-color-database find-color "RED")]
@ -1191,13 +1194,14 @@
(make-object button% "Clock" hp2.5 (lambda (b e) (do-clock #f)))
(make-object choice% #f
'("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd"
"MrEd~" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red"
"MrEd~ Opaque" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red" "M^M~ Rd Opq"
"PLT^PLT")
hp2.5
(lambda (self event)
(send canvas set-mask-ex-mode
(list-ref '(mred plt plt-mask mred^plt mred^mred
mred~ mred^mred~ opaque-mred^mred~ red-mred^mred~
mred~ mred^mred~ opaque-mred^mred~
red-mred^mred~ opaque-red-mred^mred~
plt^plt)
(send self get-selection)))))
(make-object check-box% "Kern" hp2.5

2
collects/tests/gracket/wxme.rkt
View File

@ -7,7 +7,7 @@
clipboard-client%
key-event%
mouse-event%)
mred/private/wxme/snip
racket/snip
mred/private/wxme/mline
mred/private/wxme/style
mred/private/wxme/editor