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"
"insert-large-letters.ss"
mrlib/switchable-button
mrlib/cache-image-snip
(prefix-in drscheme:arrow: "../arrow.ss")
mred
@ -112,60 +113,116 @@ module browser threading seems wrong.
(or (is-a? text (get-definitions-text%))
(is-a? text drscheme:rep:text%))
(is-a? event mouse-event%))
(let* ([end (send text get-end-position)]
[start (send text get-start-position)])
(unless (= 0 (send text last-position))
(let ([str (if (= end start)
(find-symbol
text
(call-with-values
(λ ()
(send text dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(λ (x y)
(send text find-position x y))))
(send text get-text start end))]
[language
(let ([canvas (send text get-canvas)])
(and canvas
(let ([tlw (send canvas get-top-level-window)])
(and (is-a? tlw -frame<%>)
(send (send tlw get-definitions-text)
get-next-settings)))))])
(unless (string=? str "")
(make-object separator-menu-item% menu)
(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)))
(void)))))))))
(let ([add-sep
(let ([added? #f])
(λ ()
(unless added?
(set! added? #t)
(new separator-menu-item% [parent menu]))))])
(let* ([end (send text get-end-position)]
[start (send text get-start-position)])
(unless (= 0 (send text last-position))
(let ([str (if (= end start)
(find-symbol
text
(call-with-values
(λ ()
(send text dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(λ (x y)
(send text find-position x y))))
(send text get-text start end))]
[language
(let ([canvas (send text get-canvas)])
(and canvas
(let ([tlw (send canvas get-top-level-window)])
(and (is-a? tlw -frame<%>)
(send (send tlw get-definitions-text)
get-next-settings)))))])
(unless (string=? str "")
(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
;; finds the symbol around the position `pos' (approx)
(define (find-symbol text pos)
(let* ([before
(let loop ([i (- pos 1)]
[chars null])
(if (< i 0)
chars
(let ([char (send text get-character i)])
(if (non-letter? char)
(send text split-snip pos)
(send text split-snip (+ pos 1))
(let ([snip (send text find-snip pos 'after-or-none)])
(if (is-a? snip string-snip%)
(let* ([before
(let loop ([i (- pos 1)]
[chars null])
(if (< i 0)
chars
(loop (- i 1)
(cons char chars))))))]
[after
(let loop ([i pos])
(if (< i (send text last-position))
(let ([char (send text get-character i)])
(if (non-letter? char)
null
(cons char (loop (+ i 1)))))
null))])
(apply string (append before after))))
(let ([char (send text get-character i)])
(if (non-letter? char)
chars
(loop (- i 1)
(cons char chars))))))]
[after
(let loop ([i pos])
(if (< i (send text last-position))
(let ([char (send text get-character i)])
(if (non-letter? char)
null
(cons char (loop (+ i 1)))))
null))])
(apply string (append before after)))
"")))
;; non-letter? : char -> boolean
;; 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)])
(when (object? interactions-text)
(send interactions-text reset-highlighting))))))
(define/augment (after-insert x y)
(reset-highlighting)
(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)])
(class* super% (syncheck-text<%>)
(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
find-position begin-edit-sequence end-edit-sequence
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
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)
(if arrow-vectors
(cond
@ -674,7 +645,7 @@ If the namespace does not, they are colored the unbound color.
(send event entering?))
(let-values ([(pos text) (get-pos/text event)])
(cond
[(and pos text)
[(and pos (is-a? text text%))
(unless (and (equal? pos cursor-location)
(eq? cursor-text text))
(set! cursor-location pos)
@ -707,7 +678,7 @@ If the namespace does not, they are colored the unbound color.
(super on-event event)]
[(send event button-down? 'right)
(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))])
(when arrow-vector
(let ([vec-ents (vector-ref arrow-vector pos)])

5
collects/framework/main.ss
View File

@ -909,7 +909,10 @@
(parameter-doc
keymap:add-to-right-button-menu
(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
@{When the keymap that @scheme[keymap:get-global] returns is installed
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
can-close?
close
get-filename/untitled-name))
get-filename/untitled-name
get-pos/text))
(define basic-mixin
(mixin (editor<%>) (basic<%>)
@ -49,6 +51,31 @@
(begin (on-close) #t)
#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
;; returns a string representing the visible name for this file,
;; or "Untitled <n>" for some n.
@ -291,8 +318,7 @@
(get-top-level-window)])
(finder:put-file f d)))
(super-instantiate ())))
(super-new)))
(define standard-style-list (new 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").
}
@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<%>)]{
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")
(no "No")
;; saving image (right click on an image to see the text)
(save-image "Save image...")
;;; preferences
(preferences "Preferences")
(error-saving-preferences "Error saving preferences: ~a")