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

SK requested popup menu on images to save them

Browse Source 
svn: r10637
This commit is contained in:
Robby Findler 2008-07-07 02:53:09 +00:00
parent 364d3b4787
commit e090a76187
6 changed files with 162 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

159
collects/drscheme/private/unit.ss
View File

@ -28,7 +28,8 @@ module browser threading seems wrong.
"auto-language.ss" "auto-language.ss"
"insert-large-letters.ss" "insert-large-letters.ss"
mrlib/switchable-button mrlib/switchable-button
mrlib/cache-image-snip
(prefix-in drscheme:arrow: "../arrow.ss") (prefix-in drscheme:arrow: "../arrow.ss")
mred mred
@ -112,60 +113,116 @@ module browser threading seems wrong.
(or (is-a? text (get-definitions-text%)) (or (is-a? text (get-definitions-text%))
(is-a? text drscheme:rep:text%)) (is-a? text drscheme:rep:text%))
(is-a? event mouse-event%)) (is-a? event mouse-event%))
(let* ([end (send text get-end-position)]
[start (send text get-start-position)]) (let ([add-sep
(unless (= 0 (send text last-position)) (let ([added? #f])
(let ([str (if (= end start) (λ ()
(find-symbol (unless added?
text (set! added? #t)
(call-with-values (new separator-menu-item% [parent menu]))))])
(λ ()
(send text dc-location-to-editor-location (let* ([end (send text get-end-position)]
(send event get-x) [start (send text get-start-position)])
(send event get-y))) (unless (= 0 (send text last-position))
(λ (x y) (let ([str (if (= end start)
(send text find-position x y)))) (find-symbol
(send text get-text start end))] text
[language (call-with-values
(let ([canvas (send text get-canvas)]) (λ ()
(and canvas (send text dc-location-to-editor-location
(let ([tlw (send canvas get-top-level-window)]) (send event get-x)
(and (is-a? tlw -frame<%>) (send event get-y)))
(send (send tlw get-definitions-text) (λ (x y)
get-next-settings)))))]) (send text find-position x y))))
(unless (string=? str "") (send text get-text start end))]
(make-object separator-menu-item% menu) [language
(make-object menu-item% (let ([canvas (send text get-canvas)])
(gui-utils:format-literal-label (string-constant search-help-desk-for) (and canvas
(shorten-str (let ([tlw (send canvas get-top-level-window)])
str (and (is-a? tlw -frame<%>)
(- 200 (string-length (string-constant search-help-desk-for))))) (send (send tlw get-definitions-text)
menu get-next-settings)))))])
(λ x (help-desk:help-desk str))) (unless (string=? str "")
(void))))))))) (add-sep)
(make-object menu-item%
(gui-utils:format-literal-label
(string-constant search-help-desk-for)
(shorten-str
str
(- 200 (string-length (string-constant search-help-desk-for)))))
menu
(λ x (help-desk:help-desk str)))))))
(when (is-a? text editor:basic<%>)
(let-values ([(pos text) (send text get-pos/text event)])
(when (and pos (is-a? text text%))
(send text split-snip pos)
(send text split-snip (+ pos 1))
(let ([snip (send text find-snip pos 'after-or-none)])
(when (or (is-a? snip image-snip%)
(is-a? snip cache-image-snip%))
(add-sep)
(new menu-item%
[parent menu]
[label (string-constant save-image)]
[callback
(λ (_1 _2)
(let ([fn (put-file #f
(send text get-top-level-window)
#f "untitled.png" "png")])
(when fn
(let ([kind (filename->kind fn)])
(cond
[kind
(send (send snip get-bitmap) save-file fn kind)]
[else
(message-box
(string-constant drscheme)
"Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))]))))))
(void))))))
(define (filename->kind fn)
(let ([ext (filename-extension fn)])
(and ext
(let ([sym (string->symbol (bytes->string/utf-8 ext))])
(ormap (λ (pr) (and (eq? sym (car pr)) (cadr pr)))
allowed-extensions)))))
(define allowed-extensions '((png png)
(jpg jpeg)
(xbm xbm)
(xpm xpm)))
;; find-symbol : number -> string ;; find-symbol : number -> string
;; finds the symbol around the position `pos' (approx) ;; finds the symbol around the position `pos' (approx)
(define (find-symbol text pos) (define (find-symbol text pos)
(let* ([before (send text split-snip pos)
(let loop ([i (- pos 1)] (send text split-snip (+ pos 1))
[chars null]) (let ([snip (send text find-snip pos 'after-or-none)])
(if (< i 0) (if (is-a? snip string-snip%)
chars (let* ([before
(let ([char (send text get-character i)]) (let loop ([i (- pos 1)]
(if (non-letter? char) [chars null])
(if (< i 0)
chars chars
(loop (- i 1) (let ([char (send text get-character i)])
(cons char chars))))))] (if (non-letter? char)
[after chars
(let loop ([i pos]) (loop (- i 1)
(if (< i (send text last-position)) (cons char chars))))))]
(let ([char (send text get-character i)]) [after
(if (non-letter? char) (let loop ([i pos])
null (if (< i (send text last-position))
(cons char (loop (+ i 1))))) (let ([char (send text get-character i)])
null))]) (if (non-letter? char)
(apply string (append before after)))) null
(cons char (loop (+ i 1)))))
null))])
(apply string (append before after)))
"")))
;; non-letter? : char -> boolean ;; non-letter? : char -> boolean
;; returns #t if the character belongs in a symbol (approx) and #f it is ;; returns #t if the character belongs in a symbol (approx) and #f it is
@ -293,7 +350,7 @@ module browser threading seems wrong.
(let ([interactions-text (send f get-interactions-text)]) (let ([interactions-text (send f get-interactions-text)])
(when (object? interactions-text) (when (object? interactions-text)
(send interactions-text reset-highlighting)))))) (send interactions-text reset-highlighting))))))
(define/augment (after-insert x y) (define/augment (after-insert x y)
(reset-highlighting) (reset-highlighting)
(inner (void) after-insert x y)) (inner (void) after-insert x y))

35
collects/drscheme/syncheck.ss
View File

@ -220,7 +220,7 @@ If the namespace does not, they are colored the unbound color.
(let* ([cursor-arrow (make-object cursor% 'arrow)]) (let* ([cursor-arrow (make-object cursor% 'arrow)])
(class* super% (syncheck-text<%>) (class* super% (syncheck-text<%>)
(inherit set-cursor get-admin invalidate-bitmap-cache set-position (inherit set-cursor get-admin invalidate-bitmap-cache set-position
position-location get-pos/text position-location
get-canvas last-position dc-location-to-editor-location get-canvas last-position dc-location-to-editor-location
find-position begin-edit-sequence end-edit-sequence find-position begin-edit-sequence end-edit-sequence
highlight-range unhighlight-range) highlight-range unhighlight-range)
@ -627,35 +627,6 @@ If the namespace does not, they are colored the unbound color.
(for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text
tail-arrow-to-pos tail-arrow-to-text)) tail-arrow-to-pos tail-arrow-to-text))
;; get-pos/text : event -> (values (union #f text%) (union number #f))
;; returns two #fs to indicate the event doesn't correspond to
;; a position in an editor, or returns the innermost text
;; and position in that text where the event is.
(define/private (get-pos/text event)
(let ([event-x (send event get-x)]
[event-y (send event get-y)]
[on-it? (box #f)])
(let loop ([editor this])
(let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)])
(cond
[(is-a? editor text%)
(let ([pos (send editor find-position x y #f on-it?)])
(cond
[(not (unbox on-it?)) (values #f #f)]
[else
(let ([snip (send editor find-snip pos 'after-or-none)])
(if (and snip
(is-a? snip editor-snip%))
(loop (send snip get-editor))
(values pos editor)))]))]
[(is-a? editor pasteboard%)
(let ([snip (send editor find-snip x y)])
(if (and snip
(is-a? snip editor-snip%))
(loop (send snip get-editor))
(values #f #f)))]
[else (values #f #f)])))))
(define/override (on-event event) (define/override (on-event event)
(if arrow-vectors (if arrow-vectors
(cond (cond
@ -674,7 +645,7 @@ If the namespace does not, they are colored the unbound color.
(send event entering?)) (send event entering?))
(let-values ([(pos text) (get-pos/text event)]) (let-values ([(pos text) (get-pos/text event)])
(cond (cond
[(and pos text) [(and pos (is-a? text text%))
(unless (and (equal? pos cursor-location) (unless (and (equal? pos cursor-location)
(eq? cursor-text text)) (eq? cursor-text text))
(set! cursor-location pos) (set! cursor-location pos)
@ -707,7 +678,7 @@ If the namespace does not, they are colored the unbound color.
(super on-event event)] (super on-event event)]
[(send event button-down? 'right) [(send event button-down? 'right)
(let-values ([(pos text) (get-pos/text event)]) (let-values ([(pos text) (get-pos/text event)])
(if (and pos text) (if (and pos (is-a? text text%))
(let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))])
(when arrow-vector (when arrow-vector
(let ([vec-ents (vector-ref arrow-vector pos)]) (let ([vec-ents (vector-ref arrow-vector pos)])

5
collects/framework/main.ss
View File

@ -909,7 +909,10 @@
(parameter-doc (parameter-doc
keymap:add-to-right-button-menu keymap:add-to-right-button-menu
(parameter/c (parameter/c
(-> (is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) void?)) (-> (is-a?/c popup-menu%)
(is-a?/c editor<%>)
(is-a?/c event%)
void?))
proc proc
@{When the keymap that @scheme[keymap:get-global] returns is installed @{When the keymap that @scheme[keymap:get-global] returns is installed
into an editor, this parameter's value is used for right button into an editor, this parameter's value is used for right button

32
collects/framework/private/editor.ss
View File

@ -38,7 +38,9 @@
on-close on-close
can-close? can-close?
close close
get-filename/untitled-name)) get-filename/untitled-name
get-pos/text))
(define basic-mixin (define basic-mixin
(mixin (editor<%>) (basic<%>) (mixin (editor<%>) (basic<%>)
@ -49,6 +51,31 @@
(begin (on-close) #t) (begin (on-close) #t)
#f)) #f))
(define/public (get-pos/text event)
(let ([event-x (send event get-x)]
[event-y (send event get-y)]
[on-it? (box #f)])
(let loop ([editor this])
(let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)])
(cond
[(is-a? editor text%)
(let ([pos (send editor find-position x y #f on-it?)])
(cond
[(not (unbox on-it?)) (values #f #f)]
[else
(let ([snip (send editor find-snip pos 'after-or-none)])
(if (and snip
(is-a? snip editor-snip%))
(loop (send snip get-editor))
(values pos editor)))]))]
[(is-a? editor pasteboard%)
(let ([snip (send editor find-snip x y)])
(if (and snip
(is-a? snip editor-snip%))
(loop (send snip get-editor))
(values editor #f)))]
[else (values #f #f)])))))
;; get-filename/untitled-name : -> string ;; get-filename/untitled-name : -> string
;; returns a string representing the visible name for this file, ;; returns a string representing the visible name for this file,
;; or "Untitled <n>" for some n. ;; or "Untitled <n>" for some n.
@ -291,8 +318,7 @@
(get-top-level-window)]) (get-top-level-window)])
(finder:put-file f d))) (finder:put-file f d)))
(super-new)))
(super-instantiate ())))
(define standard-style-list (new style-list%)) (define standard-style-list (new style-list%))
(define (get-standard-style-list) standard-style-list) (define (get-standard-style-list) standard-style-list)

15
collects/scribblings/framework/editor.scrbl
View File

@ -116,6 +116,21 @@
returns a symbolic name (something like "Untitled"). returns a symbolic name (something like "Untitled").
} }
@defmethod[(get-pos/text [event (is-a?/c mouse-event%)])
(values (or/c false/c (is-a?/c editor<%>))
(or/c false/c number?))]{
This method's first result is @scheme[#f] when the mouse
event does not correspond to a location in the editor.
If the first result is an @scheme[text%] object, then the
second result will be a position in the editor and
otherwise the second result will be @scheme[#f].
The @scheme[editor<%>] object will always be the nearest
enclosing editor containing the mouse click.
}
} }
@defmixin[editor:basic-mixin (editor<%>) (editor:basic<%>)]{ @defmixin[editor:basic-mixin (editor<%>) (editor:basic<%>)]{
This provides the basic editor services required by the rest of the This provides the basic editor services required by the rest of the

3
collects/string-constants/english-string-constants.ss
View File

@ -391,6 +391,9 @@ please adhere to these guidelines:
(yes "Yes") (yes "Yes")
(no "No") (no "No")
;; saving image (right click on an image to see the text)
(save-image "Save image...")
;;; preferences ;;; preferences
(preferences "Preferences") (preferences "Preferences")
(error-saving-preferences "Error saving preferences: ~a") (error-saving-preferences "Error saving preferences: ~a")