342 lines
11 KiB
Racket
342 lines
11 KiB
Racket
(module helper mzscheme
|
|
(require mzlib/class
|
|
(prefix wx: "kernel.rkt")
|
|
(prefix wx: racket/snip/private/style)
|
|
"lock.rkt")
|
|
|
|
(provide (protect (struct child-info (x-min y-min x-margin y-margin x-stretch y-stretch))
|
|
get-two-int-values
|
|
non-negative-number?
|
|
same-dimension?
|
|
list-diff
|
|
key-regexp
|
|
do-command
|
|
double-boxed
|
|
queue-window-callback
|
|
param
|
|
protect&
|
|
find-pos
|
|
no-stretch
|
|
font->delta
|
|
traverse
|
|
object->position
|
|
container->children
|
|
filter-overlapping
|
|
system-position-ok-before-cancel?
|
|
ok-cancel))
|
|
|
|
;; this structure holds the information that a child will need to send
|
|
;; to its parent when the parent must resize itself.
|
|
(define-struct child-info (x-min y-min ; includes margins!
|
|
x-margin y-margin ; requested margin space
|
|
x-stretch y-stretch)) ; booleans indicating strechability
|
|
|
|
;; get-two-int-values: a wrapper around functions that need to return
|
|
;; two results.
|
|
;; input: function: a function which takes two boxes and returns results
|
|
;; in them.
|
|
;; returns: the contents of the two boxes (as multiple values)
|
|
(define get-two-int-values
|
|
(lambda (function)
|
|
(let ([a (box 0)]
|
|
[b (box 0)])
|
|
(function a b)
|
|
(values (unbox a) (unbox b)))))
|
|
|
|
(define non-negative-number?
|
|
(lambda (n)
|
|
(and (real? n) (not (negative? n)))))
|
|
|
|
(define same-dimension?
|
|
(lambda (new-dim current-dim)
|
|
(or (= new-dim current-dim)
|
|
(= new-dim -1))))
|
|
|
|
;; list-diff: computes the difference between two lists
|
|
;; input: l1, l2: two lists
|
|
;; returns: a list of all elements in l1 which are not in l2.
|
|
(define list-diff
|
|
(lambda (l1 l2)
|
|
(let ([table (make-hash-table)])
|
|
(for-each
|
|
(lambda (item)
|
|
(hash-table-put! table item #t))
|
|
l2)
|
|
(let loop ([l l1])
|
|
(cond
|
|
[(null? l) null]
|
|
[(hash-table-get table (car l) (lambda () #f))
|
|
(loop (cdr l))]
|
|
[else (cons (car l) (loop (cdr l)))])))))
|
|
|
|
(define (key-regexp c)
|
|
(regexp (format "(^|[^&])&[~a~a]" (char-downcase c) (char-upcase c))))
|
|
|
|
(define (do-command c e)
|
|
(as-exit (lambda () (send c command e))))
|
|
|
|
(define double-boxed
|
|
(lambda (x y f)
|
|
(let ([x (box x)][y (box y)])
|
|
(f x y)
|
|
(values (unbox x) (unbox y)))))
|
|
|
|
(define (queue-window-callback w cb)
|
|
(parameterize ([wx:current-eventspace (send (send w get-top-level) get-eventspace)])
|
|
(wx:queue-callback cb wx:middle-queue-key)))
|
|
|
|
(define-syntax (param stx)
|
|
(syntax-case stx ()
|
|
[(_ get-obj method)
|
|
(syntax/loc stx
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send (get-obj) method)]
|
|
[(v) (send (get-obj) method v)])))]))
|
|
|
|
(define (font->delta f)
|
|
(define d (make-object wx:style-delta%))
|
|
(let ([v (send f get-face)]
|
|
[m (send f get-family)])
|
|
(if v
|
|
(send d set-delta-face v m)
|
|
(send d set-delta 'change-family m)))
|
|
(send d set-delta 'change-size (send f get-point-size))
|
|
(send d set-delta 'change-style (send f get-style))
|
|
(send d set-delta 'change-weight (send f get-weight))
|
|
(send d set-delta 'change-underline (send f get-underlined))
|
|
(send d set-delta 'change-smoothing (send f get-smoothing))
|
|
(send d set-delta 'change-size-in-pixels (send f get-size-in-pixels))
|
|
d)
|
|
|
|
(define protect&
|
|
(lambda (s)
|
|
(regexp-replace* #rx"&" s "\\&\\&")))
|
|
|
|
(define (find-pos l i eq?)
|
|
(let loop ([l l][n 0])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(eq? (car l) i) n]
|
|
[else (loop (cdr l) (add1 n))])))
|
|
|
|
(define (no-stretch a)
|
|
(send a stretchable-width #f) (send a stretchable-height #f))
|
|
|
|
;; ;;;;;;;;;;;;; Focus-tabbing helpers ;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (traverse x y w h dir dests)
|
|
;; x, y : real = starting positions
|
|
;; dir : one of 'left, 'right, 'up, 'next, 'prev = desried move
|
|
;; dests : list of (cons key x y w h) = destinations
|
|
;; returns key or #f
|
|
(case dir
|
|
[(next prev)
|
|
(letrec ([get-x cadr]
|
|
[get-w cadddr]
|
|
[get-y caddr]
|
|
[get-h (lambda (x) (caddr (cddr x)))]
|
|
[backward? (eq? dir 'prev)]
|
|
[fail-start (if backward?
|
|
1000000000
|
|
0)]
|
|
[find-stripe (lambda (t stripes)
|
|
(let loop ([s stripes])
|
|
(cond
|
|
[(null? s) #f]
|
|
[(and (<= (caar s) t) (< t (cdar s)))
|
|
(car s)]
|
|
[else (loop (cdr s))])))]
|
|
[mk-stripes
|
|
(lambda (get-y get-h stripes dests)
|
|
(let loop ([l (append (map (lambda (x) (cons (car x) (- (cdr x) (car x))))
|
|
stripes)
|
|
(map (lambda (x)
|
|
(cons (get-y x) (get-h x)))
|
|
dests))])
|
|
(if (null? l)
|
|
null
|
|
;; Find longest top-most
|
|
(let* ([top (let loop ([l (cdr l)][best (car l)])
|
|
(cond
|
|
[(null? l) best]
|
|
[(or (< (caar l) (car best)) ; topmost
|
|
(and (= (caar l) (car best)) ; at least as top
|
|
(> (cdar l) (cdr best)))) ; longer
|
|
(loop (cdr l) (car l))]
|
|
[else (loop (cdr l) best)]))]
|
|
[t (car top)]
|
|
[b (+ t (cdr top))])
|
|
;; Stripe is anything that starts before the end of `top'
|
|
(let ([remaining (let loop ([l l])
|
|
(cond
|
|
[(null? l) null]
|
|
[(find-stripe (caar l) (list (cons t b)))
|
|
(loop (cdr l))]
|
|
[else (cons (car l) (loop (cdr l)))]))])
|
|
(cons (cons t b) (loop remaining)))))))]
|
|
[in-stripe (lambda (stripe dests get-y get-h)
|
|
(let loop ([l dests])
|
|
(cond
|
|
[(null? l) null]
|
|
[(find-stripe (get-y (car l)) (list stripe))
|
|
(cons (car l) (loop (cdr l)))]
|
|
[else (loop (cdr l))])))]
|
|
[next-stripe (lambda (stripe stripes)
|
|
(let loop ([s stripes][best #f])
|
|
(cond
|
|
[(null? s) best]
|
|
[(and (or (not stripe)
|
|
(if backward?
|
|
(<= (cdar s) (car stripe))
|
|
(>= (caar s) (cdr stripe))))
|
|
(or (not best)
|
|
(if backward?
|
|
(> (cdar s) (cdr best))
|
|
(< (caar s) (cdr best)))))
|
|
(loop (cdr s) (car s))]
|
|
[else (loop (cdr s) best)])))]
|
|
[find (lambda (v? get-x get-w get-y get-h use-x? x w use-y? y h dests fail)
|
|
;; find's variable names correspond to an h-stripe view, but everything is
|
|
;; flipped to v-stripes if the args are flipped
|
|
(let ([h-stripes (mk-stripes get-y get-h
|
|
(if use-y? (list (cons y (+ y h))) null)
|
|
dests)])
|
|
|
|
;; find the initial h-stripe
|
|
(let sel-h-stripe-loop ([init-h-stripe (if use-y?
|
|
(find-stripe y h-stripes)
|
|
(next-stripe #f h-stripes))]
|
|
[x x][w w][use-x? use-x?])
|
|
|
|
;; find items in the initial stripe
|
|
(let ([in-init-h-stripe (in-stripe init-h-stripe dests get-y get-h)]
|
|
[next (lambda ()
|
|
(let ([s (next-stripe init-h-stripe h-stripes)])
|
|
(if s
|
|
(sel-h-stripe-loop s fail-start fail-start #f)
|
|
(fail))))])
|
|
|
|
(if (null? in-init-h-stripe)
|
|
|
|
;; no items in this stripe; try the next one
|
|
(next)
|
|
|
|
;; Non-empty h-stripe; now look for items in the same or later v-stripe
|
|
(if (or (null? (cdr in-init-h-stripe))
|
|
;; If we're already in "v-stripe" mode, then flipping back
|
|
;; to h-stripe mode is going to loop forever, so treat the
|
|
;; current strip as having only one item. (This should
|
|
;; happen only if the start positions overlap with the
|
|
;; destination positions.)
|
|
v?)
|
|
|
|
;; one item in the stripe; take it unless we're using x and it's
|
|
;; before x:
|
|
(if (or (not use-x?)
|
|
((if backward? < >) (get-x (car in-init-h-stripe)) x))
|
|
(car in-init-h-stripe)
|
|
|
|
;; Only item is no good; try the next stripe
|
|
(next))
|
|
|
|
;; Recur to work with v-stripes
|
|
(find #t get-y get-h get-x get-w use-y? y h use-x? x w in-init-h-stripe next)))))))])
|
|
(if (null? dests)
|
|
#f
|
|
(car (find #f get-x get-w get-y get-h #t x w #t y h dests
|
|
(lambda ()
|
|
(find #f get-x get-w get-y get-h
|
|
#f fail-start fail-start
|
|
#f fail-start fail-start
|
|
dests void))))))]
|
|
[else
|
|
(let ([v (let loop ([d dests])
|
|
(if (null? d)
|
|
#f
|
|
(let* ([best (loop (cdr d))]
|
|
[this (car d)]
|
|
[diff (lambda (v l x w)
|
|
(cond
|
|
[(< (+ v l) x) (- x (+ v l))]
|
|
[(< (+ x w) v) (- (+ x w) v)]
|
|
[else 0]))])
|
|
(let* ([get-x cadr]
|
|
[get-w cadddr]
|
|
[get-y caddr]
|
|
[get-h (lambda (x) (caddr (cddr x)))]
|
|
[tdx (diff x w (get-x this) (get-w this))]
|
|
[tdy (diff y h (get-y this) (get-h this))]
|
|
[bdx (and best (diff x w (get-x best) (get-w best)))]
|
|
[bdy (and best (diff y h (get-y best) (get-h best)))]
|
|
[better (lambda (tdx tdy bdy negative?)
|
|
(if (and (zero? tdx) (negative? tdy)
|
|
(or (not best)
|
|
(< (abs tdy) (abs bdy))))
|
|
this
|
|
best))])
|
|
(case dir
|
|
[(up) (better tdx tdy bdy negative?)]
|
|
[(down) (better tdx tdy bdy positive?)]
|
|
[(left) (better tdy tdx bdx negative?)]
|
|
[(right) (better tdy tdx bdx positive?)])))))])
|
|
(and v (car v)))]))
|
|
|
|
(define (object->position o)
|
|
(let-values ([(x y) (double-boxed 0 0 (lambda (x y) (send o client-to-screen x y)))]
|
|
[(w h) (double-boxed 0 0 (lambda (x y) (send o get-client-size x y)))])
|
|
(send o tabbing-position x y w h)))
|
|
|
|
(define (container->children f except must-focus?)
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (i)
|
|
(append
|
|
(if (and (send i has-tabbing-children?)
|
|
(send i is-shown-to-root?))
|
|
(container->children i except must-focus?)
|
|
null)
|
|
(cond
|
|
[(or (eq? i except)
|
|
(and must-focus? (not (send i gets-focus?)))
|
|
(not (send i is-enabled-to-root?))
|
|
(not (send i is-shown-to-root?)))
|
|
null]
|
|
[else (list i)])))
|
|
(send f get-children))))
|
|
|
|
(define (filter-overlapping l)
|
|
(if (null? l)
|
|
null
|
|
(let* ([rest (filter-overlapping (cdr l))]
|
|
[first (car l)]
|
|
[f (cdr first)]
|
|
[x (car f)]
|
|
[y (cadr f)]
|
|
[x2 (+ x (caddr f))]
|
|
[y2 (+ y (cadddr f))])
|
|
(if (ormap (lambda (other)
|
|
(let* ([p (cdr other)]
|
|
[px (car p)]
|
|
[py (cadr p)]
|
|
[px2 (+ px (caddr p))]
|
|
[py2 (+ py (cadddr p))])
|
|
(and (or (<= x px x2) (<= x px2 x2)
|
|
(<= px x px2) (<= px x2 px2))
|
|
(or (<= y py y2) (<= y py2 y2)
|
|
(<= py y py2) (<= py y2 py2)))))
|
|
rest)
|
|
rest
|
|
(cons first rest)))))
|
|
|
|
(define (system-position-ok-before-cancel?)
|
|
(eq? (system-type) 'windows))
|
|
|
|
(define (ok-cancel mk-ok mk-cancel)
|
|
(if (system-position-ok-before-cancel?)
|
|
(values (mk-ok) (mk-cancel))
|
|
(let ([c (mk-cancel)]
|
|
[o (mk-ok)])
|
|
(values o c)))))
|