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

allow pin-over to accept pict-finding paths, etc.

Browse Source 
svn: r7430
This commit is contained in:
Matthew Flatt 2007-10-04 06:24:43 +00:00
parent 4b435dd9c1
commit b025b527df
3 changed files with 35 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/slideshow/viewer.ss
View File

@ -319,7 +319,7 @@
[y (send background-f get-y)]) [y (send background-f get-y)])
(send background-f move (+ x dx) (+ y dy))))) (send background-f move (+ x dx) (+ y dy)))))
(define/private (prev) (define/public (prev)
(stop-transition) (stop-transition)
(set! current-page (set! current-page
(let loop ([pos (max (sub1 current-page) 0)]) (let loop ([pos (max (sub1 current-page) 0)])
@ -504,9 +504,11 @@
(send (new (class editor-canvas% (send (new (class editor-canvas%
(define/override (on-event e) (define/override (on-event e)
(super on-event e) (super on-event e)
(when (and click-to-advance? (when click-to-advance?
(send e button-up?)) (when (send e button-up? 'left)
(send f next))) (send f next))
(when (send e button-up? 'right)
(send f prev))))
(super-new)) (super-new))
[parent c-frame] [parent c-frame]
[editor commentary] [editor commentary]
@ -638,9 +640,12 @@
(set! clicking #f) (set! clicking #f)
(when hit? (when hit?
((click-region-thunk c))))] ((click-region-thunk c))))]
[(send e button-up?) [(send e button-up? 'left)
(when click-to-advance? (when click-to-advance?
(send (get-top-level-window) next))] (send (get-top-level-window) next))]
[(send e button-up? 'right)
(when click-to-advance?
(send (get-top-level-window) prev))]
[else [else
(when (and clicking clicking-hit?) (when (and clicking clicking-hit?)
(invert-clicking! #f)) (invert-clicking! #f))

4
collects/texpict/private/common-unit.ss
View File

@ -811,7 +811,9 @@
(cond (cond
[(and (number? dx) (number? dy)) [(and (number? dx) (number? dy))
(values dx (- (pict-height base) dy))] (values dx (- (pict-height base) dy))]
[(and (pict? dx) (procedure? dy) [(and (or (pict? dx)
(and (list? dx) (andmap pict? dx)))
(procedure? dy)
(procedure-arity-includes? dy 2)) (procedure-arity-includes? dy 2))
(if flip? (if flip?
(let-values ([(dx dy) (dy base dx)]) (let-values ([(dx dy) (dy base dx)])

39
collects/texpict/utils.ss
View File

@ -931,26 +931,31 @@
(define cellophane (define cellophane
(case-lambda (case-lambda
[(p alpha-factor) [(p alpha-factor)
(let ([drawer (make-pict-drawer p)]) (cond
(let ([new [(= 1.0 alpha-factor)
(dc (inset p 0)]
(lambda (dc x y) [(zero? alpha-factor)
(unless (zero? alpha-factor) (ghost p)]
[else
(let ([drawer (make-pict-drawer p)])
(let ([new
(dc
(lambda (dc x y)
(let ([a (send dc get-alpha)]) (let ([a (send dc get-alpha)])
(send dc set-alpha (* a alpha-factor)) (send dc set-alpha (* a alpha-factor))
(drawer dc x y) (drawer dc x y)
(send dc set-alpha a)))) (send dc set-alpha a)))
(pict-width p) (pict-width p)
(pict-height p) (pict-height p)
(pict-ascent p) (pict-ascent p)
(pict-descent p))]) (pict-descent p))])
(make-pict (pict-draw new) (make-pict (pict-draw new)
(pict-width new) (pict-width new)
(pict-height new) (pict-height new)
(pict-ascent new) (pict-ascent new)
(pict-descent new) (pict-descent new)
(list (make-child p 0 0 1 1)) (list (make-child p 0 0 1 1))
#f)))])) #f)))])]))
(define inset/clip (define inset/clip
(case-lambda (case-lambda