I have these two helpers (typed racket makes it a little verbose).
(define change-style : (->* ((Instance Style<%>))
(#:font (Option (Instance Font%))
#:color (Option (Instance Color%))
#:background-color (Option (Instance Color%)))
(Instance Style<%>))
(lambda [style #:font [font #false] #:color [color #false]
#:background-color [bgcolor #false]]
(send style set-delta
(let* ([style (make-object style-delta%)]
[style (if (false? color) style (send style
set-delta-foreground color))]
[style (if (false? bgcolor) style (send style
set-delta-background bgcolor))])
(cond [(false? font) style]
[else (send* style
(set-face (send font get-face))
(set-family (send font get-family)))
(send+ style
(set-delta 'change-style (send font
get-style))
(set-delta 'change-weight (send font
get-weight))
(set-delta 'change-smoothing (send font
get-smoothing))
(set-delta 'change-underline (send font
get-underlined))
(set-delta 'change-size (min (exact-round
(send font get-size)) 255)))])))
style))
(define change-default-style! : (->* ((U (Instance Editor<%>) (Instance
Style-List%)))
(#:font (Option (Instance Font%))
#:color (Option (Instance Color%))
#:background-color (Option (Instance
Color%)))
(Instance Style<%>))
(lambda [src #:font [font #false] #:color [color #false]
#:background-color [bgcolor #false]]
(define-values (style-list style-name)
(cond [(text%? src) (values (send src get-style-list) (send src
default-style-name))]
[(pasteboard%? src) (values (send src get-style-list) (send src
default-style-name))]
[else (values (if (style-list%? src) src (make-object
style-list%)) "Standard")]))
(change-style #:font font #:color color #:background-color bgcolor
(or (send style-list find-named-style style-name)
(send style-list new-named-style style-name (send
style-list basic-style))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
This line is put in the class body of new instance of Editor<%> (not
editor-canvas%):
(change-default-style! this #:font font ...)
The idea is attaching a style-delta% object to the standard style, then the
altered style becomes
the top-level one so that it will never be `undo`ed by accident.
The awkward thing here is, I cannot make it work in a simple example,
however it works fine in my real world application.
On Thu, Jan 26, 2017 at 7:00 PM, Erich Rast <er...@snafu.de> wrote:
> Hi,
>
> I have an editor-canvas% subclass and want to set the default style,
> but adding it with name "Standard" to the-style-list doesn't work. Do
> I have to replace the style list of the canvas with a new one? Or does
> the default style of an editor-canvas% have to be called differently?
> "Basic"?
>
> Without the right default style set-line-count also doesn't work as
> desired. It sets the wrong size for lines with smaller fonts that are
> added, so I assume this method is based on the default style. But which
> style is exactly the default style "Basic" or "Standard", and how do I
> change it?
>
> best,
>
> Erich
>
> -----
>
> ; Example (sorry, not runnable, because it uses my own preference and
> ; what I call 'metastyle' impementation)
> ; layout-init does not really change the style, which
> ; is why I use set-style for every snip. But then set-line-count
> ; doesn't work as desired.
>
> (define console%
> (class editor-canvas%
> (inherit scroll-with-bottom-base allow-scroll-to-last)
>
> (define text #f)
> (define console-style #f)
> (define sema (make-semaphore 1))
>
> (define (layout-init)
> (define style (send the-style-list
> find-named-style "Basic"))
> (set! console-style (send the-style-list
> find-or-create-style
> style
> (metastyle->style
> (pref:console-style))))
> (send the-style-list new-named-style "Standard" console-style)
> (set! text
> (new text%
> [auto-wrap #t]
> [line-spacing 0]))
> (send this set-editor text)
> (scroll-with-bottom-base #t)
> (allow-scroll-to-last #t)
> (send this set-line-count 2))
>
> (define (synced-add-line msg)
> (send text begin-edit-sequence)
> (send text set-position (send text last-position))
> (define snip (make-object string-snip% msg))
> (send snip set-style console-style)
> (send text insert #\newline)
> (send text insert snip)
> (send text end-edit-sequence)
> (send text scroll-to-position (send text last-position))
> (semaphore-post sema))
>
> (define/public (add-line msg)
> (call-with-semaphore
> sema
> (lambda ()
> (synced-add-line msg))))
>
> (define/public (show-message msg delay)
> (if (> delay 0)
> (call-once/delayed
> (lambda ()
> (queue-callback
> (lambda ()
> (send this add-line msg))))
> delay)
> (add-line msg)))
>
> (super-new
> [style '(auto-vscroll auto-hscroll no-border no-focus transparent)]
> [wheel-step 1]
> [scrolls-per-page 10]
> [stretchable-height #f])
> (layout-init)))
>
>
> --
> You received this message because you are subscribed to the Google Groups
> "Racket Users" group.
> To unsubscribe from this group and stop receiving emails from it, send an
> email to racket-users+unsubscr...@googlegroups.com.
> For more options, visit https://groups.google.com/d/optout.
>
--
You received this message because you are subscribed to the Google Groups
"Racket Users" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to racket-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.
