some fixes prompted by the test suite
This commit is contained in:
Matthew Flatt
parent
20ab31743d
commit
4f2e59e7a6
|
|
@ -30,7 +30,8 @@
|
|||
(cairo_destroy cr))
|
||||
s))
|
||||
|
||||
(define/override (ok?) #t)
|
||||
(define/override (ok?) (and s #t))
|
||||
|
||||
(define/override (is-color?) #t)
|
||||
|
||||
(define/override (get-cairo-surface) s)
|
||||
|
|
@ -40,4 +41,4 @@
|
|||
(atomically
|
||||
(when s
|
||||
(cairo_surface_destroy s)
|
||||
(set! s #f))))))
|
||||
(set! s #f))))))
|
||||
|
|
|
|||
|
|
@ -331,9 +331,12 @@
|
|||
(if (or is-combo? (not (memq 'gl style)))
|
||||
(tell (tell (if is-combo? MyComboBox MyView) alloc)
|
||||
initWithFrame: #:type _NSRect r)
|
||||
(tell (tell MyGLView alloc)
|
||||
initWithFrame: #:type _NSRect r
|
||||
pixelFormat: (gl-config->pixel-format gl-config))))))
|
||||
(let ([pf (gl-config->pixel-format gl-config)])
|
||||
(begin0
|
||||
(tell (tell MyGLView alloc)
|
||||
initWithFrame: #:type _NSRect r
|
||||
pixelFormat: pf)
|
||||
(tellv pf release)))))))
|
||||
(tell #:type _void cocoa addSubview: content-cocoa)
|
||||
(set-ivar! content-cocoa wxb (->wxb this))
|
||||
|
||||
|
|
@ -462,12 +465,12 @@
|
|||
(scroll-page h-scroller h-page)
|
||||
(scroll-pos h-scroller h-pos)
|
||||
(when h-scroller
|
||||
(tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
|
||||
(tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
|
||||
(scroll-range v-scroller v-len)
|
||||
(scroll-page v-scroller v-page)
|
||||
(scroll-pos v-scroller v-pos)
|
||||
(when v-scroller
|
||||
(tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
|
||||
(tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
|
||||
|
||||
(define/override (reset-dc-for-autoscroll)
|
||||
(fix-dc))
|
||||
|
|
@ -484,12 +487,20 @@
|
|||
(define/public (set-scroll-pos which v)
|
||||
(update which scroll-pos v))
|
||||
|
||||
(define/private (guard-scroll which v)
|
||||
(if (is-auto-scroll?)
|
||||
0
|
||||
v))
|
||||
|
||||
(define/public (get-scroll-page which)
|
||||
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))
|
||||
(guard-scroll which
|
||||
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller))))
|
||||
(define/public (get-scroll-range which)
|
||||
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))
|
||||
(guard-scroll which
|
||||
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller))))
|
||||
(define/public (get-scroll-pos which)
|
||||
(scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))
|
||||
(guard-scroll which
|
||||
(scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))))
|
||||
|
||||
(define v-scroller
|
||||
(and vscroll-ok?
|
||||
|
|
@ -703,7 +714,7 @@
|
|||
(when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller))))
|
||||
(when (is-auto-scroll?) (refresh-for-autoscroll)))
|
||||
|
||||
(def/public-unimplemented warp-pointer)
|
||||
(define/public (warp-pointer x y) (void))
|
||||
|
||||
(define/override (get-virtual-h-pos)
|
||||
(scroll-pos h-scroller))
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@
|
|||
[time-stamp (current-milliseconds)])))
|
||||
|
||||
(define/public (set-selection i)
|
||||
(tell (get-cocoa) selectItemAtIndex: #:type _NSInteger i))
|
||||
(tellv (get-cocoa) selectItemAtIndex: #:type _NSInteger i))
|
||||
(define/public (get-selection)
|
||||
(tell #:type _NSInteger (get-cocoa) indexOfSelectedItem))
|
||||
(define/public (number)
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@
|
|||
(inherit get-cocoa get-parent
|
||||
get-eventspace
|
||||
pre-on-char pre-on-event
|
||||
get-x get-y
|
||||
get-x
|
||||
on-new-child)
|
||||
|
||||
(super-new [parent parent]
|
||||
|
|
@ -168,7 +168,8 @@
|
|||
(atomically
|
||||
(let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")])
|
||||
(tellv cocoa setToolbar: tb)
|
||||
(tellv tb setVisible: #:type _BOOL #f))))
|
||||
(tellv tb setVisible: #:type _BOOL #f)
|
||||
(tellv tb release))))
|
||||
|
||||
(move -11111 (if (= y -11111) 0 y))
|
||||
|
||||
|
|
@ -380,6 +381,9 @@
|
|||
|
||||
(define/override (flip y h) (flip-screen (+ y h)))
|
||||
|
||||
(define/override (get-y)
|
||||
(- (super get-y) (if caption? 22 0)))
|
||||
|
||||
(define/override (set-size x y w h)
|
||||
(unless (and (= x -1) (= y -1))
|
||||
(move x y))
|
||||
|
|
@ -399,10 +403,6 @@
|
|||
(NSPoint-x (NSRect-origin f)))
|
||||
;; keep current y position:
|
||||
(- (NSPoint-y (NSRect-origin f))
|
||||
;; we have to subtract add the titlebar height, for some reason:
|
||||
(if caption?
|
||||
(- 22)
|
||||
0)
|
||||
(- h
|
||||
(NSSize-height (NSRect-size f)))))
|
||||
(make-NSSize w h))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,10 @@
|
|||
(inherit get-cocoa)
|
||||
|
||||
(super-new [parent parent]
|
||||
[cocoa (let ([cocoa (as-objc-allocation
|
||||
[cocoa (let ([cocoa (values ; as-objc-allocation
|
||||
;; We're leaving guages for now. There's some problem
|
||||
;; releasing gauges through a finalizer. My guess is that
|
||||
;; it has something to do with animation in a separate thread.
|
||||
(tell (tell MyProgressIndicator alloc) init))])
|
||||
(tellv cocoa setIndeterminate: #:type _BOOL #f)
|
||||
(tellv cocoa setMaxValue: #:type _double* rng)
|
||||
|
|
@ -60,7 +63,8 @@
|
|||
(define/public (get-range)
|
||||
(inexact->exact (floor (tell #:type _double cocoa maxValue))))
|
||||
(define/public (set-range rng)
|
||||
(tellv cocoa setMaxValue: #:type _double* rng))
|
||||
(tellv cocoa setMaxValue: #:type _double* rng)
|
||||
(tellv cocoa setDoubleValue: #:type _double* (min rng (tell #:type _double cocoa doubleValue))))
|
||||
|
||||
(define/public (set-value v)
|
||||
(tellv cocoa setDoubleValue: #:type _double* v))
|
||||
|
|
|
|||
|
|
@ -92,7 +92,8 @@
|
|||
(tellv cocoa setDocumentView: content-cocoa)
|
||||
(tellv cocoa setHasVerticalScroller: #:type _BOOL #t)
|
||||
(tellv content-cocoa setHeaderView: #f)
|
||||
(unless (eq? kind 'single)
|
||||
(define allow-multi? (not (eq? kind 'single)))
|
||||
(when allow-multi?
|
||||
(tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t))
|
||||
|
||||
(define/override (get-cocoa-content) content-cocoa)
|
||||
|
|
@ -174,7 +175,7 @@
|
|||
(let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
|
||||
(tellv content-cocoa
|
||||
selectRowIndexes: index
|
||||
byExtendingSelection: #:type _BOOL extend?))))
|
||||
byExtendingSelection: #:type _BOOL (and extend? allow-multi?)))))
|
||||
(tellv content-cocoa deselectRow: #:type _NSInteger i)))
|
||||
(define/public (set-selection i)
|
||||
(select i #t #f))
|
||||
|
|
|
|||
|
|
@ -115,7 +115,8 @@
|
|||
(def/public-unimplemented set-width)
|
||||
(def/public-unimplemented set-title)
|
||||
|
||||
(def/public-unimplemented set-help-string)
|
||||
(define/public (set-help-string m s) (void))
|
||||
|
||||
(def/public-unimplemented number)
|
||||
|
||||
(define/private (find-pos item)
|
||||
|
|
|
|||
|
|
@ -82,5 +82,5 @@
|
|||
(as-objc-allocation
|
||||
(tell (tell MyPanelView alloc)
|
||||
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
|
||||
(make-NSSize w h))))]
|
||||
(make-NSSize (max 1 w) (max 1 h)))))]
|
||||
[no-show? (memq 'deleted style)]))
|
||||
|
|
|
|||
|
|
@ -214,6 +214,7 @@
|
|||
;; Call this function only in atomic mode:
|
||||
(define (check-one-event wait? dequeue?)
|
||||
(pre-event-sync wait?)
|
||||
(clean-up-deleted)
|
||||
(let ([pool (tell (tell NSAutoreleasePool alloc) init)])
|
||||
(when (and events-suspended? wait?)
|
||||
(set! was-menu-bar #f)
|
||||
|
|
|
|||
|
|
@ -117,11 +117,13 @@
|
|||
0
|
||||
(set-focus)))
|
||||
|
||||
(define/private (get-button i)
|
||||
(tell (get-cocoa)
|
||||
cellAtRow: #:type _NSUInteger (if horiz? 0 i)
|
||||
column: #:type _NSUInteger (if horiz? i 0)))
|
||||
|
||||
(define/public (enable-button i on?)
|
||||
(tellv (tell (get-cocoa)
|
||||
cellAtRow: #:type _NSUInteger (if horiz? 0 i)
|
||||
column: #:type _NSUInteger (if horiz? i 0))
|
||||
setEnabled: #:type _BOOL on?))
|
||||
(tellv (get-button i) setEnabled: #:type _BOOL on?))
|
||||
|
||||
(define/public (set-selection i)
|
||||
(if (= i -1)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
ffi/unsafe
|
||||
ffi/unsafe/alloc
|
||||
ffi/unsafe/define
|
||||
"../common/utils.rkt")
|
||||
"../common/utils.rkt"
|
||||
"../../lock.rkt")
|
||||
|
||||
(provide cocoa-lib
|
||||
cf-lib
|
||||
|
|
@ -14,6 +15,7 @@
|
|||
define-mz
|
||||
as-objc-allocation
|
||||
as-objc-allocation-with-retain
|
||||
clean-up-deleted
|
||||
retain release
|
||||
with-autorelease
|
||||
clean-menu-label
|
||||
|
|
@ -31,8 +33,19 @@
|
|||
(define-ffi-definer define-appserv appserv-lib)
|
||||
(define-ffi-definer define-appkit appkit-lib)
|
||||
|
||||
(define (objc-delete v)
|
||||
(tellv v release))
|
||||
(define delete-me null)
|
||||
|
||||
(define (objc-delete o)
|
||||
(atomically
|
||||
(set! delete-me (cons o delete-me))))
|
||||
|
||||
(define (clean-up-deleted)
|
||||
;; called outside the event loop to actually delete objects
|
||||
;; that might otherwise be in use during a callback
|
||||
(for ([o (in-list (begin0
|
||||
delete-me
|
||||
(set! delete-me null)))])
|
||||
(tellv o release)))
|
||||
|
||||
(define objc-allocator (allocator objc-delete))
|
||||
|
||||
|
|
@ -59,7 +72,7 @@
|
|||
(let ([pool (tell (tell NSAutoreleasePool alloc) init)])
|
||||
(begin0
|
||||
(thunk)
|
||||
(release pool))))
|
||||
(tellv pool release))))
|
||||
|
||||
(define (clean-menu-label str)
|
||||
(regexp-replace* #rx"&(.)" str "\\1"))
|
||||
|
|
|
|||
|
|
@ -42,6 +42,8 @@
|
|||
|
||||
(super-new)
|
||||
|
||||
(define/override (ok?) #t)
|
||||
|
||||
;; Override this method to get the right size
|
||||
(define/public (get-backing-size xb yb)
|
||||
(set-box! xb 1)
|
||||
|
|
|
|||
|
|
@ -383,6 +383,10 @@
|
|||
[(and (eq? evt 'wait)
|
||||
(not handler?))
|
||||
#t]
|
||||
;; `yield' is supposed to return immediately if the
|
||||
;; event is already ready:
|
||||
[(and (evt? evt) (sync/timeout 0 (wrap-evt evt (lambda (v) (list v)))))
|
||||
=> (lambda (v) (car v))]
|
||||
[handler?
|
||||
(sync (if (eq? evt 'wait)
|
||||
(wrap-evt e (lambda (_) #t))
|
||||
|
|
@ -411,18 +415,24 @@
|
|||
(eq? e main-eventspace))
|
||||
|
||||
(define (queue-callback thunk [high? #t])
|
||||
(queue-event (current-eventspace) thunk (cond
|
||||
[(not high?) 'lo]
|
||||
[(eq? high? middle-queue-key) 'med]
|
||||
[else 'hi])))
|
||||
(let ([es (current-eventspace)])
|
||||
(when (eventspace-shutdown? es)
|
||||
(error 'queue-callback "eventspace is shutdown: ~e" es))
|
||||
(queue-event es thunk (cond
|
||||
[(not high?) 'lo]
|
||||
[(eq? high? middle-queue-key) 'med]
|
||||
[else 'hi]))))
|
||||
|
||||
(define middle-queue-key (gensym 'middle))
|
||||
|
||||
|
||||
(define (add-timer-callback cb)
|
||||
(queue-event (current-eventspace) cb 'timer-add))
|
||||
(define (remove-timer-callback cb)
|
||||
(queue-event (current-eventspace) cb 'timer-remove))
|
||||
(define (add-timer-callback cb es)
|
||||
;; in atomic mode
|
||||
(queue-event es cb 'timer-add))
|
||||
(define (remove-timer-callback cb es)
|
||||
;; in atomic mode
|
||||
(unless (eventspace-shutdown? es)
|
||||
(queue-event es cb 'timer-remove)))
|
||||
|
||||
(define (register-frame-shown f on?)
|
||||
(queue-event (current-eventspace) f (if on?
|
||||
|
|
|
|||
|
|
@ -15,11 +15,18 @@
|
|||
(define current-interval ival)
|
||||
(define current-once? (and just-once? #t))
|
||||
(define cb #f)
|
||||
(define es (current-eventspace))
|
||||
|
||||
(when (eventspace-shutdown? es)
|
||||
(error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es))
|
||||
|
||||
(def/public (interval) current-interval)
|
||||
(define/private (do-start msec once?)
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(do-stop)
|
||||
(when (eventspace-shutdown? es)
|
||||
(error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es))
|
||||
(set! current-interval msec)
|
||||
(set! current-once? (and once? #t))
|
||||
(letrec ([new-cb
|
||||
|
|
@ -33,14 +40,14 @@
|
|||
(when (eq? cb new-cb)
|
||||
(do-start msec #f))))))))])
|
||||
(set! cb new-cb)
|
||||
(add-timer-callback new-cb)))))
|
||||
(add-timer-callback new-cb es)))))
|
||||
(def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]])
|
||||
(do-start msec once?))
|
||||
(define/private (do-stop)
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(when cb
|
||||
(remove-timer-callback cb)
|
||||
(remove-timer-callback cb es)
|
||||
(set! cb #f)))))
|
||||
(def/public (stop) (do-stop))
|
||||
(def/public (notify) (notify-cb) (void))
|
||||
|
|
|
|||
|
|
@ -476,14 +476,20 @@
|
|||
(gtk_adjustment_set_value adj v))))))
|
||||
|
||||
(define/public (get-scroll-page which)
|
||||
(->long (dispatch which gtk_adjustment_get_page_size 0)))
|
||||
(if (is-auto-scroll?)
|
||||
0
|
||||
(->long (dispatch which gtk_adjustment_get_page_size 0))))
|
||||
(define/public (get-scroll-range which)
|
||||
(->long (dispatch which (lambda (adj)
|
||||
(- (gtk_adjustment_get_upper adj)
|
||||
(gtk_adjustment_get_page_size adj)))
|
||||
0)))
|
||||
(if (is-auto-scroll?)
|
||||
0
|
||||
(->long (dispatch which (lambda (adj)
|
||||
(- (gtk_adjustment_get_upper adj)
|
||||
(gtk_adjustment_get_page_size adj)))
|
||||
0))))
|
||||
(define/public (get-scroll-pos which)
|
||||
(->long (dispatch which gtk_adjustment_get_value 0)))
|
||||
(if (is-auto-scroll?)
|
||||
0
|
||||
(->long (dispatch which gtk_adjustment_get_value 0))))
|
||||
|
||||
(define clear-bg?
|
||||
(and (not (memq 'transparent style))
|
||||
|
|
@ -541,12 +547,12 @@
|
|||
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))))
|
||||
(when (is-auto-scroll?) (refresh-for-autoscroll)))
|
||||
|
||||
(def/public-unimplemented warp-pointer)
|
||||
(define/public (warp-pointer x y) (void))
|
||||
|
||||
(define/override (get-virtual-h-pos)
|
||||
(gtk_adjustment_get_value hscroll-adj))
|
||||
(define/override (get-virtual-v-pos)
|
||||
(gtk_adjustment_get_value vscroll-adj))
|
||||
(inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj))))
|
||||
(define/override (get-virtual-v-pos)
|
||||
(inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj))))
|
||||
|
||||
(define/public (set-resize-corner on?) (void))
|
||||
|
||||
|
|
|
|||
|
|
@ -53,6 +53,9 @@
|
|||
|
||||
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
|
||||
|
||||
(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
|
||||
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
|
||||
|
||||
(define-cstruct _GdkGeometry ([min_width _int]
|
||||
[min_height _int]
|
||||
[max_width _int]
|
||||
|
|
@ -429,6 +432,7 @@
|
|||
(send in-window enter-window)))
|
||||
|
||||
(define maximized? #f)
|
||||
(define is-iconized? #f)
|
||||
|
||||
(define/public (is-maximized?)
|
||||
maximized?)
|
||||
|
|
@ -437,11 +441,18 @@
|
|||
|
||||
(define/public (on-window-state changed value)
|
||||
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED))
|
||||
(set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED)))))
|
||||
(set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))
|
||||
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED))
|
||||
(set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED)))))
|
||||
|
||||
(def/public-unimplemented iconized?)
|
||||
(define/public (iconized?)
|
||||
is-iconized?)
|
||||
(define/public (iconize on?)
|
||||
(if on?
|
||||
(gtk_window_iconify gtk)
|
||||
(gtk_window_deiconify gtk)))
|
||||
|
||||
(def/public-unimplemented get-menu-bar)
|
||||
(def/public-unimplemented iconize)
|
||||
|
||||
(define/public (set-title s)
|
||||
(set! saved-title s)
|
||||
|
|
|
|||
|
|
@ -25,6 +25,9 @@
|
|||
(define _GtkCellRenderer (_cpointer 'GtkCellRenderer))
|
||||
(define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn)
|
||||
|
||||
(define GTK_SELECTION_SINGLE 1)
|
||||
(define GTK_SELECTION_MULTIPLE 3)
|
||||
|
||||
(define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget))
|
||||
(define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void))
|
||||
|
||||
|
|
@ -38,6 +41,7 @@
|
|||
(define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn))
|
||||
(define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void))
|
||||
(define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget))
|
||||
(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void))
|
||||
(define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean))
|
||||
(define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean))
|
||||
(define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void))
|
||||
|
|
@ -112,6 +116,11 @@
|
|||
(define selection
|
||||
(gtk_tree_view_get_selection client-gtk))
|
||||
|
||||
(gtk_tree_selection_set_mode selection (if (or (eq? kind 'extended)
|
||||
(eq? kind 'multiple))
|
||||
GTK_SELECTION_MULTIPLE
|
||||
GTK_SELECTION_SINGLE))
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk gtk]
|
||||
[extra-gtks (list client-gtk selection)]
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@
|
|||
(def/public-unimplemented set-width)
|
||||
(def/public-unimplemented set-title)
|
||||
|
||||
(def/public-unimplemented set-help-string)
|
||||
(define/public (set-help-string m s) (void))
|
||||
|
||||
(define/public (number) (length items))
|
||||
|
||||
|
|
|
|||
|
|
@ -69,8 +69,8 @@
|
|||
(if (memq 'hscroll style) WS_HSCROLL 0)
|
||||
(cond
|
||||
;; Win32 sense of "multiple" and "extended" is backwards
|
||||
[(memq 'extended style) LBS_MULTIPLESEL]
|
||||
[(memq 'multiple style) LBS_EXTENDEDSEL]
|
||||
[(eq? kind 'extended) LBS_MULTIPLESEL]
|
||||
[(eq? kind 'multiple) LBS_EXTENDEDSEL]
|
||||
[else 0]))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
(module wxitem mzscheme
|
||||
(module wxitem racket/base
|
||||
(require mzlib/class
|
||||
mzlib/class100
|
||||
mzlib/etc
|
||||
(prefix wx: "kernel.ss")
|
||||
(prefix-in wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"helper.ss"
|
||||
"const.ss"
|
||||
|
|
@ -10,12 +10,12 @@
|
|||
"check.ss"
|
||||
"wxwindow.ss")
|
||||
|
||||
(provide (protect make-item%
|
||||
make-control%
|
||||
make-simple-control%
|
||||
wx-button%
|
||||
wx-check-box%
|
||||
wx-message%))
|
||||
(provide (protect-out make-item%
|
||||
make-control%
|
||||
make-simple-control%
|
||||
wx-button%
|
||||
wx-check-box%
|
||||
wx-message%))
|
||||
|
||||
;; make-item%: creates items which are suitable for placing into
|
||||
;; containers.
|
||||
|
|
@ -61,8 +61,7 @@
|
|||
(super set-size x y width height)))])
|
||||
|
||||
(public
|
||||
[is-enabled?
|
||||
(lambda () enabled?)])
|
||||
[is-enabled? (lambda () enabled?)])
|
||||
|
||||
(private-field
|
||||
;; Store minimum size of item.
|
||||
|
|
@ -207,10 +206,8 @@
|
|||
(apply super-init args)
|
||||
(send (get-parent) set-item-cursor 0 0))))
|
||||
|
||||
(define (make-simple-control% item%)
|
||||
(make-control% item%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f))
|
||||
(define (make-simple-control% item% [x-m const-default-x-margin] [y-m const-default-y-margin])
|
||||
(make-control% item% x-m y-m #f #f))
|
||||
|
||||
(define wx-button% (make-window-glue%
|
||||
(class100 (make-simple-control% wx:button%) (parent cb label x y w h style font)
|
||||
|
|
|
|||
|
|
@ -55,12 +55,13 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define wx-label-panel%
|
||||
(class wx-horizontal-panel%
|
||||
(class wx-control-horizontal-panel%
|
||||
(init proxy parent label style font halign valign)
|
||||
(inherit area-parent)
|
||||
(define c #f)
|
||||
|
||||
(define/override (enable on?) (if c (send c enable on?) (void)))
|
||||
(define/override (is-enabled?) (if c (send c is-enabled?) #t))
|
||||
(define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t))
|
||||
|
||||
(super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
|
||||
|
|
@ -83,7 +84,7 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define wx-internal-choice%
|
||||
(class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
|
||||
(class100 (make-window-glue% (make-simple-control% wx:choice% 0 0)) (mred proxy parent cb label x y w h choices style font)
|
||||
(override
|
||||
[handles-key-code
|
||||
(lambda (x alpha? meta?)
|
||||
|
|
@ -119,9 +120,7 @@
|
|||
|
||||
(define wx-internal-list-box%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:list-box%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#t #t) (parent cb label kind x y w h choices style font label-font)
|
||||
(class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font)
|
||||
(inherit get-first-item
|
||||
set-first-visible-item)
|
||||
(private
|
||||
|
|
@ -194,7 +193,7 @@
|
|||
|
||||
(define wx-internal-radio-box%
|
||||
(make-window-glue%
|
||||
(class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
|
||||
(class100 (make-simple-control% wx:radio-box% 0 0) (parent cb label x y w h choices major style font)
|
||||
(inherit number orig-enable set-selection command)
|
||||
(override
|
||||
[enable
|
||||
|
|
@ -233,10 +232,21 @@
|
|||
major (filter-style style) font))
|
||||
(set-c c #t #t)
|
||||
|
||||
(define enable-vector (make-vector (length choices) #t))
|
||||
|
||||
(define/override enable
|
||||
(case-lambda
|
||||
[(on?) (super enable on?)]
|
||||
[(i on?) (send c enable-button i on?)]))
|
||||
[(i on?)
|
||||
(when (< -1 i (vector-length enable-vector))
|
||||
(vector-set! enable-vector i on?)
|
||||
(send c enable-button i on?))]))
|
||||
|
||||
(define/override is-enabled?
|
||||
(case-lambda
|
||||
[() (super is-enabled?)]
|
||||
[(which) (and (< -1 which (vector-length enable-vector))
|
||||
(vector-ref enable-vector which))]))
|
||||
|
||||
(bounce
|
||||
c
|
||||
|
|
@ -250,9 +260,7 @@
|
|||
|
||||
(define wx-internal-gauge%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:gauge%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f)
|
||||
(class100 (make-control% wx:gauge% 0 0 #f #f)
|
||||
(parent label range style font)
|
||||
(inherit get-client-size get-width get-height set-size
|
||||
stretchable-in-x stretchable-in-y set-min-height set-min-width
|
||||
|
|
@ -324,9 +332,7 @@
|
|||
|
||||
(define wx-internal-slider%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:slider%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f)
|
||||
(class100 (make-control% wx:slider% 0 0 #f #f)
|
||||
(parent func label value min-val max-val style font)
|
||||
(inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
|
||||
get-client-size get-width get-height get-parent)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
(module wxpanel mzscheme
|
||||
(module wxpanel racket/base
|
||||
(require mzlib/class
|
||||
mzlib/class100
|
||||
mzlib/list
|
||||
(prefix wx: "kernel.ss")
|
||||
(prefix-in wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"const.ss"
|
||||
"helper.ss"
|
||||
|
|
@ -12,15 +12,16 @@
|
|||
"wxitem.ss"
|
||||
"wxcontainer.ss")
|
||||
|
||||
(provide (protect wx-panel%
|
||||
wx-vertical-panel%
|
||||
wx-vertical-tab-panel%
|
||||
wx-vertical-group-panel%
|
||||
wx-horizontal-panel%
|
||||
wx-pane%
|
||||
wx-vertical-pane%
|
||||
wx-horizontal-pane%
|
||||
wx-grow-box-pane%))
|
||||
(provide (protect-out wx-panel%
|
||||
wx-vertical-panel%
|
||||
wx-vertical-tab-panel%
|
||||
wx-vertical-group-panel%
|
||||
wx-horizontal-panel%
|
||||
wx-control-horizontal-panel%
|
||||
wx-pane%
|
||||
wx-vertical-pane%
|
||||
wx-horizontal-pane%
|
||||
wx-grow-box-pane%))
|
||||
|
||||
(define wx:windowless-panel%
|
||||
(class100 object% (prnt x y w h style label)
|
||||
|
|
@ -61,8 +62,8 @@
|
|||
0
|
||||
2))
|
||||
|
||||
(define (wx-make-basic-panel% wx:panel% stretch?)
|
||||
(class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style label)
|
||||
(define (wx-make-basic-panel% wx:panel% stretch? [x-m 0] [y-m 0])
|
||||
(class100* (wx-make-container% (make-item% wx:panel% x-m y-m stretch? stretch?)) (wx-basic-panel<%>) (parent style label)
|
||||
(inherit get-x get-y get-width get-height
|
||||
min-width min-height set-min-width set-min-height
|
||||
x-margin y-margin
|
||||
|
|
@ -476,8 +477,8 @@
|
|||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define (wx-make-panel% wx:panel%)
|
||||
(class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args
|
||||
(define (wx-make-panel% wx:panel% [x-m 0] [y-m 0])
|
||||
(class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t x-m y-m))) args
|
||||
(rename [super-on-visible on-visible]
|
||||
[super-on-active on-active])
|
||||
(inherit get-children)
|
||||
|
|
@ -724,15 +725,18 @@
|
|||
(define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f))
|
||||
|
||||
(define wx-panel% (wx-make-panel% wx:panel%))
|
||||
(define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin))
|
||||
(define wx-tab-panel% (wx-make-panel% wx:tab-panel%))
|
||||
(define wx-group-panel% (wx-make-panel% wx:group-panel%))
|
||||
(define wx-linear-panel% (wx-make-linear-panel% wx-panel%))
|
||||
(define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%))
|
||||
(define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%))
|
||||
(define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%))
|
||||
(define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%))
|
||||
(define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%))
|
||||
(define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%))
|
||||
(define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%))
|
||||
(define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%))
|
||||
|
||||
(define wx-pane% (wx-make-pane% wx:windowless-panel% #t))
|
||||
(define wx-grow-box-pane%
|
||||
|
|
|
|||
|
|
@ -23,6 +23,8 @@
|
|||
(when _bm
|
||||
(do-set-bitmap _bm #f))
|
||||
|
||||
(define/override (ok?) (and c #t))
|
||||
|
||||
(define/private (do-set-bitmap v reset?)
|
||||
(when c
|
||||
(cairo_destroy c)
|
||||
|
|
@ -79,7 +81,8 @@
|
|||
(class (dc-mixin bitmap-dc-backend%)
|
||||
(inherit draw-bitmap-section
|
||||
internal-set-bitmap
|
||||
internal-get-bitmap)
|
||||
internal-get-bitmap
|
||||
get-size)
|
||||
|
||||
(super-new)
|
||||
|
||||
|
|
@ -99,10 +102,11 @@
|
|||
(set-argb-pixels x y 1 1 s)))
|
||||
|
||||
(def/public (get-pixel [real? x][real? y][color% c])
|
||||
(let ([b (make-bytes 4)])
|
||||
(get-argb-pixels x y 1 1 b)
|
||||
(send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
|
||||
#t))
|
||||
(let-values ([(w h) (get-size)])
|
||||
(let ([b (make-bytes 4)])
|
||||
(get-argb-pixels x y 1 1 b)
|
||||
(send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
|
||||
(and (<= 0 x w) (<= 0 y h)))))
|
||||
|
||||
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
|
||||
[exact-nonnegative-integer? y]
|
||||
|
|
|
|||
|
|
@ -114,8 +114,9 @@
|
|||
#f)]
|
||||
[([(make-alts path-string? input-port?) filename]
|
||||
[kind-symbol? [kind 'unknown]]
|
||||
[(make-or-false color%) [bg-color #f]])
|
||||
(let-values ([(s b&w?) (do-load-bitmap filename kind bg-color)]
|
||||
[(make-or-false color%) [bg-color #f]]
|
||||
[any? [complain-on-failure? #f]])
|
||||
(let-values ([(s b&w?) (do-load-bitmap filename kind bg-color complain-on-failure?)]
|
||||
[(alpha?) (memq kind '(unknown/alpha gif/alpha jpeg/alpha
|
||||
png/alpha xbm/alpha xpm/alpha
|
||||
bmp/alpha))]
|
||||
|
|
@ -218,18 +219,23 @@
|
|||
|
||||
(def/public (load-bitmap [(make-alts path-string? input-port?) in]
|
||||
[kind-symbol? [kind 'unknown]]
|
||||
[(make-or-false color%) [bg #f]])
|
||||
[(make-or-false color%) [bg #f]]
|
||||
[any? [complain-on-failure? #f]])
|
||||
(check-alternate 'load-bitmap)
|
||||
(release-bitmap-storage)
|
||||
(set!-values (s b&w?) (do-load-bitmap in kind bg))
|
||||
(set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?))
|
||||
(set! width (if s (cairo_image_surface_get_width s) 0))
|
||||
(set! height (if s (cairo_image_surface_get_height s) 0)))
|
||||
|
||||
(define/private (do-load-bitmap in kind bg)
|
||||
(define/private (do-load-bitmap in kind bg complain-on-failure?)
|
||||
(if (path-string? in)
|
||||
(call-with-input-file*
|
||||
in
|
||||
(lambda (in) (do-load-bitmap in kind bg)))
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(if complain-on-failure?
|
||||
(raise exn)
|
||||
(values #f #f)))])
|
||||
(call-with-input-file*
|
||||
in
|
||||
(lambda (in) (do-load-bitmap in kind bg #f))))
|
||||
(case kind
|
||||
[(unknown unknown/mask unknown/alpha)
|
||||
(let ([starts? (lambda (s)
|
||||
|
|
@ -242,20 +248,21 @@
|
|||
(if (eq? kind 'unknown/mask)
|
||||
'png/mask
|
||||
'png))
|
||||
bg)]
|
||||
bg
|
||||
complain-on-failure?)]
|
||||
[(starts? #"\xFF\xD8\xFF")
|
||||
(do-load-bitmap in 'jpeg bg)]
|
||||
(do-load-bitmap in 'jpeg bg complain-on-failure?)]
|
||||
[(starts? #"GIF8")
|
||||
(do-load-bitmap in 'gif bg)]
|
||||
(do-load-bitmap in 'gif bg complain-on-failure?)]
|
||||
[(starts? #"BM")
|
||||
(do-load-bitmap in 'bmp bg)]
|
||||
(do-load-bitmap in 'bmp bg complain-on-failure?)]
|
||||
[(starts? #"#define")
|
||||
(do-load-bitmap in 'xbm bg)]
|
||||
(do-load-bitmap in 'xbm bg complain-on-failure?)]
|
||||
[(starts? #"/* XPM */")
|
||||
(do-load-bitmap in 'xpm bg)]
|
||||
(do-load-bitmap in 'xpm bg complain-on-failure?)]
|
||||
[else
|
||||
;; unrecognized file type; try to parse as XBM
|
||||
(do-load-bitmap in 'xbm bg)]))]
|
||||
(do-load-bitmap in 'xbm bg complain-on-failure?)]))]
|
||||
[(png png/mask png/alpha)
|
||||
;; Using the Cairo PNG support is about twice as fast, but we have
|
||||
;; less control, and there are problems making deallocation reliable
|
||||
|
|
|
|||
|
|
@ -189,7 +189,7 @@
|
|||
1
|
||||
0))
|
||||
|
||||
(define/public (ok?) (and (get-cr) #t))
|
||||
(define/public (ok?) #t)
|
||||
|
||||
(define/public (dc-adjust-smoothing s) s)
|
||||
|
||||
|
|
@ -241,7 +241,7 @@
|
|||
(inherit flush-cr get-cr release-cr end-cr init-cr-matrix get-pango
|
||||
install-color dc-adjust-smoothing reset-clip
|
||||
collapse-bitmap-b&w? call-with-cr-lock
|
||||
can-combine-text? can-mask-bitmap?)
|
||||
ok? can-combine-text? can-mask-bitmap?)
|
||||
|
||||
(define-syntax-rule (with-cr default cr . body)
|
||||
;; Faster:
|
||||
|
|
@ -363,7 +363,8 @@
|
|||
(set! origin-y oy)
|
||||
(reset-effective!)
|
||||
(reset-matrix)))
|
||||
(def/public (get-origin) (values origin-x origin-y))
|
||||
(def/public (get-origin)
|
||||
(values origin-x origin-y))
|
||||
|
||||
(def/public (set-rotation [real? th])
|
||||
(unless (and (equal? rotation th))
|
||||
|
|
@ -527,7 +528,7 @@
|
|||
[pen-style-symbol? style])
|
||||
(do-set-pen! (send the-pen-list find-or-create-pen col width style))
|
||||
(reset-align!)]
|
||||
(method-name 'dc% 'set-pen)))
|
||||
(method-name 'dc<%> 'set-pen)))
|
||||
|
||||
(define/public (get-pen) pen)
|
||||
|
||||
|
|
@ -548,7 +549,7 @@
|
|||
[([(make-alts string? color%) col]
|
||||
[brush-style-symbol? style])
|
||||
(do-set-brush! (send the-brush-list find-or-create-brush col style))]
|
||||
(method-name 'dc% 'set-brush)))
|
||||
(method-name 'dc<%> 'set-brush)))
|
||||
|
||||
(define/public (get-brush) brush)
|
||||
|
||||
|
|
@ -568,6 +569,10 @@
|
|||
(def/public (get-text-background) text-bg)
|
||||
(def/public (get-background) bg)
|
||||
|
||||
(define/override (get-size)
|
||||
(check-ok 'get-size)
|
||||
(super get-size))
|
||||
|
||||
(def/public (suspend-flush) (void))
|
||||
(def/public (resume-flush) (void))
|
||||
|
||||
|
|
@ -576,7 +581,16 @@
|
|||
(def/public (get-text-mode) text-mode)
|
||||
|
||||
(def/public (try-color [color% c] [color% dest])
|
||||
(send dest set (color-red c) (color-green c) (color-blue c)))
|
||||
(check-ok 'try-color)
|
||||
(if (collapse-bitmap-b&w?)
|
||||
(let ([v (if (= 255
|
||||
(color-red c)
|
||||
(color-green c)
|
||||
(color-blue c))
|
||||
255
|
||||
0)])
|
||||
(send dest set v v v))
|
||||
(send dest set (color-red c) (color-green c) (color-blue c))))
|
||||
|
||||
(define clipping-region #f)
|
||||
|
||||
|
|
@ -621,16 +635,20 @@
|
|||
(send r set-rectangle x y w h)
|
||||
(do-set-clipping-region r)))
|
||||
|
||||
(define/private (check-ok who)
|
||||
(unless (ok?)
|
||||
(raise-mismatch-error (method-name 'dc<%> who) "drawing context is not ok: " this)))
|
||||
|
||||
(define/public (clear)
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'erase)
|
||||
cr
|
||||
(install-color cr bg 1.0)
|
||||
(cairo_paint cr)))
|
||||
|
||||
(define/override (erase)
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'erase)
|
||||
cr
|
||||
(cairo_set_operator cr CAIRO_OPERATOR_CLEAR)
|
||||
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
|
||||
|
|
@ -640,7 +658,7 @@
|
|||
(def/public (copy [real? x] [real? y] [nonnegative-real? w] [nonnegative-real? h]
|
||||
[real? x2] [real? y2])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'copy)
|
||||
cr
|
||||
(cairo_set_source_surface cr
|
||||
(cairo_get_target cr)
|
||||
|
|
@ -830,11 +848,12 @@
|
|||
(cairo_set_dash cr #() 0)))))
|
||||
(flush-cr))
|
||||
|
||||
(define/public (draw-arc x y
|
||||
width height
|
||||
start-radians end-radians)
|
||||
(define/private (do-draw-arc who
|
||||
x y
|
||||
width height
|
||||
start-radians end-radians)
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok who)
|
||||
cr
|
||||
(let ([draw-one (lambda (align-x align-y brush? pen? d)
|
||||
(let* ([orig-x x]
|
||||
|
|
@ -870,15 +889,19 @@
|
|||
(when (pen-draws?)
|
||||
(draw-one (lambda (x) (align-x x)) (lambda (y) (align-y y)) #f #t 1.0)))))
|
||||
|
||||
(def/public (draw-arc [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height]
|
||||
[real? start-radians] [real? end-radians])
|
||||
(do-draw-arc 'draw-arc x y width height 0 2pi))
|
||||
|
||||
(def/public (draw-ellipse [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height])
|
||||
(draw-arc x y width height 0 2pi))
|
||||
(do-draw-arc 'draw-ellipse x y width height 0 2pi))
|
||||
|
||||
(def/public (draw-line [real? x1] [real? y1] [real? x2] [real? y2])
|
||||
(let ([dot (if (and (= x1 x2) (= y1 y2))
|
||||
0.1
|
||||
0)])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-line)
|
||||
cr
|
||||
(cairo_new_path cr)
|
||||
(cairo_move_to cr (align-x x1) (align-y y1))
|
||||
|
|
@ -887,7 +910,7 @@
|
|||
|
||||
(def/public (draw-point [real? x] [real? y])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-point)
|
||||
cr
|
||||
(cairo_new_path cr)
|
||||
(let ([x (align-x x)]
|
||||
|
|
@ -898,37 +921,38 @@
|
|||
|
||||
(def/public (draw-lines [(make-alts (make-list point%) list-of-pair-of-real?) pts]
|
||||
[real? [x 0.0]] [real? [y 0.0]])
|
||||
(do-draw-lines pts x y #f))
|
||||
(do-draw-lines 'draw-lines pts x y #f))
|
||||
|
||||
(def/public (draw-polygon [(make-alts (make-list point%) list-of-pair-of-real?) pts]
|
||||
[real? [x 0.0]] [real? [y 0.0]]
|
||||
[(symbol-in odd-even winding) [fill-style 'odd-even]])
|
||||
(do-draw-lines pts x y fill-style))
|
||||
(do-draw-lines 'draw-polygon pts x y fill-style))
|
||||
|
||||
(define/public (do-draw-lines pts x y fill-style)
|
||||
(unless (or (null? pts)
|
||||
(null? (cdr pts)))
|
||||
(with-cr
|
||||
(void)
|
||||
cr
|
||||
(cairo_new_path cr)
|
||||
(if (pair? (car pts))
|
||||
(cairo_move_to cr (align-x (+ x (caar pts))) (align-y (+ y (cdar pts))))
|
||||
(cairo_move_to cr (align-x (+ x (point-x (car pts)))) (align-y (+ y (point-y (car pts))))))
|
||||
(for ([p (in-list (cdr pts))])
|
||||
(if (pair? p)
|
||||
(cairo_line_to cr (align-x (+ x (car p))) (align-y (+ y (cdr p))))
|
||||
(cairo_line_to cr (align-x (+ x (point-x p))) (align-y (+ y (point-y p))))))
|
||||
(when fill-style
|
||||
(cairo_close_path cr)
|
||||
(cairo_set_fill_rule cr (if (eq? fill-style 'winding)
|
||||
CAIRO_FILL_RULE_WINDING
|
||||
CAIRO_FILL_RULE_EVEN_ODD)))
|
||||
(draw cr fill-style #t))))
|
||||
(define/public (do-draw-lines who pts x y fill-style)
|
||||
(if (or (null? pts)
|
||||
(null? (cdr pts)))
|
||||
(check-ok who)
|
||||
(with-cr
|
||||
(check-ok who)
|
||||
cr
|
||||
(cairo_new_path cr)
|
||||
(if (pair? (car pts))
|
||||
(cairo_move_to cr (align-x (+ x (caar pts))) (align-y (+ y (cdar pts))))
|
||||
(cairo_move_to cr (align-x (+ x (point-x (car pts)))) (align-y (+ y (point-y (car pts))))))
|
||||
(for ([p (in-list (cdr pts))])
|
||||
(if (pair? p)
|
||||
(cairo_line_to cr (align-x (+ x (car p))) (align-y (+ y (cdr p))))
|
||||
(cairo_line_to cr (align-x (+ x (point-x p))) (align-y (+ y (point-y p))))))
|
||||
(when fill-style
|
||||
(cairo_close_path cr)
|
||||
(cairo_set_fill_rule cr (if (eq? fill-style 'winding)
|
||||
CAIRO_FILL_RULE_WINDING
|
||||
CAIRO_FILL_RULE_EVEN_ODD)))
|
||||
(draw cr fill-style #t))))
|
||||
|
||||
(def/public (draw-rectangle [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-rectangle)
|
||||
cr
|
||||
;; have to do pen separate from brush for
|
||||
;; both alignment and height/width adjustment
|
||||
|
|
@ -946,7 +970,7 @@
|
|||
(def/public (draw-rounded-rectangle [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height]
|
||||
[real? [radius -0.25]])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-rounded-rectangle)
|
||||
cr
|
||||
;; have to do pen separate from brush for
|
||||
;; both alignment and height/width adjustment
|
||||
|
|
@ -966,7 +990,7 @@
|
|||
|
||||
(def/public (draw-spline [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-spline)
|
||||
cr
|
||||
(cairo_new_path cr)
|
||||
(cairo_move_to cr (align-x x1) (align-y y1))
|
||||
|
|
@ -991,7 +1015,7 @@
|
|||
[real? [dy 0]]
|
||||
[(symbol-in odd-even winding) [fill-style 'odd-even]])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-path)
|
||||
cr
|
||||
(cairo_save cr)
|
||||
(cairo_set_fill_rule cr (if (eq? fill-style 'winding)
|
||||
|
|
@ -1013,13 +1037,12 @@
|
|||
(draw cr #t #t)))
|
||||
(cairo_restore cr)))
|
||||
|
||||
(inherit get-size)
|
||||
(def/public (draw-text [string? s] [real? x] [real? y]
|
||||
[any? [combine? #f]]
|
||||
[exact-nonnegative-integer? [offset 0]]
|
||||
[real? [angle 0.0]])
|
||||
(with-cr
|
||||
(void)
|
||||
(check-ok 'draw-text)
|
||||
cr
|
||||
(do-text cr #t s x y font combine? offset angle)
|
||||
(flush-cr)))
|
||||
|
|
@ -1036,6 +1059,7 @@
|
|||
[(make-or-false font%) [use-font font]]
|
||||
[any? [combine? #f]]
|
||||
[exact-nonnegative-integer? [offset 0]])
|
||||
(check-ok 'get-text-extent)
|
||||
(let ([use-font (or use-font font)])
|
||||
;; Try to used cached size info, first:
|
||||
(let-values ([(w h d a)
|
||||
|
|
@ -1397,13 +1421,14 @@
|
|||
10.0)
|
||||
|
||||
(def/public (start-doc [string? desc])
|
||||
(void))
|
||||
(check-ok 'start-doc))
|
||||
(def/public (end-doc)
|
||||
(check-ok 'end-doc)
|
||||
(end-cr))
|
||||
(def/public (start-page)
|
||||
(void))
|
||||
(check-ok 'start-page))
|
||||
(def/public (end-page)
|
||||
(with-cr (void) cr (cairo_show_page cr)))
|
||||
(with-cr (check-ok 'end-page) cr (cairo_show_page cr)))
|
||||
|
||||
(def/public (draw-bitmap [bitmap% src]
|
||||
[real? dest-x]
|
||||
|
|
@ -1411,11 +1436,13 @@
|
|||
[(symbol-in solid opaque xor) [style 'solid]]
|
||||
[(make-or-false color%) [color black]]
|
||||
[(make-or-false bitmap%) [mask #f]])
|
||||
(draw-bitmap-section src
|
||||
dest-x dest-y
|
||||
0 0
|
||||
(send src get-width) (send src get-height)
|
||||
style color mask))
|
||||
(draw-bitmap-section/mask-offset 'draw-bitmap
|
||||
src
|
||||
dest-x dest-y
|
||||
0 0
|
||||
(send src get-width) (send src get-height)
|
||||
0 0
|
||||
style color mask))
|
||||
|
||||
(def/public (draw-bitmap-section [bitmap% src]
|
||||
[real? dest-x]
|
||||
|
|
@ -1427,11 +1454,14 @@
|
|||
[(symbol-in solid opaque xor) [style 'solid]]
|
||||
[(make-or-false color%) [color black]]
|
||||
[(make-or-false bitmap%) [mask #f]])
|
||||
(draw-bitmap-section/mask-offset src dest-x dest-y src-x src-y src-w src-h src-x src-y
|
||||
(draw-bitmap-section/mask-offset 'draw-bitmap-section
|
||||
src dest-x dest-y src-x src-y src-w src-h src-x src-y
|
||||
style color mask))
|
||||
|
||||
(define/public (draw-bitmap-section/mask-offset src dest-x dest-y src-x src-y src-w src-h msrc-x msrc-y
|
||||
(define/public (draw-bitmap-section/mask-offset who
|
||||
src dest-x dest-y src-x src-y src-w src-h msrc-x msrc-y
|
||||
style color mask)
|
||||
(check-ok who)
|
||||
(let-values ([(src src-x src-y)
|
||||
(if (and (alpha . < . 1.0)
|
||||
(send src is-color?))
|
||||
|
|
@ -1594,7 +1624,7 @@
|
|||
[tmp-dc (make-object -bitmap-dc% tmp-bm)])
|
||||
(send tmp-dc set-alpha alpha)
|
||||
(send tmp-dc set-background bg)
|
||||
(send tmp-dc draw-bitmap-section/mask-offset src 0 0 src-x src-y src-w src-h msrc-x msrc-y
|
||||
(send tmp-dc draw-bitmap-section/mask-offset 'internal src 0 0 src-x src-y src-w src-h msrc-x msrc-y
|
||||
style color mask)
|
||||
(send tmp-dc set-bitmap #f)
|
||||
tmp-bm))
|
||||
|
|
|
|||
|
|
@ -83,6 +83,8 @@
|
|||
|
||||
(when s (cairo_surface_destroy s))
|
||||
|
||||
(define/override (ok?) (and c #t))
|
||||
|
||||
(define/override (get-cr) c)
|
||||
|
||||
(def/override (get-size)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,11 @@
|
|||
(send-generic mdc (make-generic (object-interface mdc) m) . args)
|
||||
(error 'bad-dc "~a shouldn't succeed" `(send <bad-dc> ,m ...))))
|
||||
|
||||
(define (test-all mdc try)
|
||||
(define (good m . args)
|
||||
(send-generic mdc (make-generic (object-interface mdc) m) . args))
|
||||
|
||||
(define (test-all mdc try try-ok)
|
||||
(try 'erase)
|
||||
(try 'clear)
|
||||
(try 'draw-arc 0 0 10 10 0.1 0.2)
|
||||
(try 'draw-bitmap bm2 0 0)
|
||||
|
|
@ -40,35 +44,46 @@
|
|||
(try 'end-page)
|
||||
(try 'end-doc)
|
||||
|
||||
(try 'get-background)
|
||||
(try 'get-brush)
|
||||
(try 'get-clipping-region)
|
||||
(try 'get-font)
|
||||
(try 'get-pen)
|
||||
(try 'get-size)
|
||||
(try 'get-text-background)
|
||||
(try 'get-text-foreground)
|
||||
(try 'get-text-mode)
|
||||
|
||||
(try 'set-background (make-object color% "Yellow"))
|
||||
(try 'set-brush (make-object brush% "Yellow" 'solid))
|
||||
(try 'set-clipping-rect 0 0 10 10)
|
||||
(try 'set-clipping-region (make-object region% mdc))
|
||||
(try 'set-font (make-object font% 12 'default 'normal 'normal))
|
||||
(try 'set-origin 0 0)
|
||||
(try 'set-pen (make-object pen% "Yellow" 1 'solid))
|
||||
(try 'set-scale 2 2)
|
||||
(try 'set-text-background (make-object color% "Yellow"))
|
||||
(try 'set-text-foreground (make-object color% "Yellow"))
|
||||
(try 'set-text-mode 'transparent)
|
||||
(try-ok 'get-background)
|
||||
(try-ok 'get-brush)
|
||||
(try-ok 'get-clipping-region)
|
||||
(try-ok 'get-font)
|
||||
(try-ok 'get-pen)
|
||||
(try-ok 'get-text-background)
|
||||
(try-ok 'get-text-foreground)
|
||||
(try-ok 'get-text-mode)
|
||||
(try-ok 'get-alpha)
|
||||
(try-ok 'get-scale)
|
||||
(try-ok 'get-origin)
|
||||
(try-ok 'get-rotation)
|
||||
|
||||
(try-ok 'set-background (make-object color% "Yellow"))
|
||||
(try-ok 'set-brush (make-object brush% "Yellow" 'solid))
|
||||
(try-ok 'set-clipping-rect 0 0 10 10)
|
||||
(try-ok 'set-clipping-region (make-object region% mdc))
|
||||
(try-ok 'set-font (make-object font% 12 'default 'normal 'normal))
|
||||
(try-ok 'set-origin 0 0)
|
||||
(try-ok 'set-pen (make-object pen% "Yellow" 1 'solid))
|
||||
(try-ok 'set-scale 2 2)
|
||||
(try-ok 'set-alpha 0.75)
|
||||
(try-ok 'set-text-background (make-object color% "Yellow"))
|
||||
(try-ok 'set-text-foreground (make-object color% "Yellow"))
|
||||
(try-ok 'set-text-mode 'transparent)
|
||||
|
||||
(try 'try-color (make-object color% "Yellow") (make-object color%)))
|
||||
|
||||
(st #f mdc ok?)
|
||||
(test-all mdc bad)
|
||||
(test-all mdc bad good)
|
||||
|
||||
(send mdc set-bitmap bm)
|
||||
(test-all mdc (lambda (m . args)
|
||||
(send-generic mdc (make-generic (object-interface mdc) m) . args)))
|
||||
|
||||
(test-all mdc
|
||||
(lambda (m . args)
|
||||
(send-generic mdc (make-generic (object-interface mdc) m) . args))
|
||||
(lambda (m . args)
|
||||
(send-generic mdc (make-generic (object-interface mdc) m) . args)))
|
||||
|
||||
(send mdc set-bitmap #f)
|
||||
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
|
||||
(define d (make-object dialog% "hello"))
|
||||
(thread (lambda ()
|
||||
(sleep 1)
|
||||
(sync (system-idle-evt))
|
||||
(queue-callback (lambda () (set! v 11)))
|
||||
(send d show #f)))
|
||||
(queue-callback (lambda () (set! v 10)))
|
||||
|
|
@ -56,15 +56,17 @@
|
|||
(st #f d is-shown?)
|
||||
|
||||
(let ([t (thread (lambda ()
|
||||
(send d show #t)))])
|
||||
(let loop () (unless (send d is-shown?) (loop)))
|
||||
(send d show #t)))])
|
||||
(let loop () (unless (send d is-shown?) (sleep) (loop)))
|
||||
(st #t d is-shown?)
|
||||
(thread-suspend t)
|
||||
(stv d show #f)
|
||||
(st #f d is-shown?)
|
||||
(let ([t2 (thread (lambda () (send d show #t)))])
|
||||
(sleep 0.1)
|
||||
(yield (system-idle-evt))
|
||||
(st #t d is-shown?)
|
||||
(thread-resume t)
|
||||
(sleep 0.1)
|
||||
(yield (system-idle-evt))
|
||||
(st #t d is-shown?)
|
||||
(test #t 'thread2 (thread-running? t2))
|
||||
(stv d show #f)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user