racket / draw Goto Github PK

View Code? Open in Web Editor NEW

16.0 23.0 23.0 1.09 MB

License: Other

Racket 100.00%

racket

draw's Introduction

draw

This the source for the Racket packages: "draw", "draw-doc", "draw-lib", "draw-test".

Contributing

Contribute to Racket by submitting a pull request, reporting an issue, joining the development mailing list, or visiting the IRC or Slack channels.

License

Racket, including these packages, is free software, see LICENSE for more details.

By making a contribution, you are agreeing that your contribution is licensed under the Apache 2.0 license and the MIT license.

draw's People

Contributors

Stargazers

Watchers

draw's Issues

[Feature Request] draw font% does not expose kerning

Is your feature request related to a problem? Please describe.
It is not possible to draw the letters "V" and "A" correctly next to each other, because the library racket/draw does not expose the kerning table of a font.

Describe the solution you'd like
I would like to have a function, which returns the kerning similar to kerning-value of "sfont".

It would be nice to have a function, which calculates the kerning between two strings or characters. It seems to me that currently this is the only way to calculate the kerning between two strings:

#lang racket/gui

(define font (make-font #:size 16 #:face "Latin Modern Roman"))

(define frame (new frame% [label ""]))
(define canvas (new canvas% [parent frame]))

(define dc (send canvas get-dc))

(define left "A")
(define right "V")
(define both (string-append left right))

(define-values (left-text-width left-text-height left-baseline-height left-extra-height)
  (send dc get-text-extent left font #t))
(values left-text-width left-text-height left-baseline-height left-extra-height)
(printf "\n")

(define-values (right-text-width right-text-height right-baseline-height right-extra-height)
  (send dc get-text-extent right font #t))
(values right-text-width right-text-height right-baseline-height right-extra-height)
(printf "\n")

(define-values (both-text-width both-text-height both-baseline-height both-extra-height)
  (send dc get-text-extent both font #t))
(values both-text-width both-text-height both-baseline-height both-extra-height)
(printf "\n")

(- (+ left-text-width right-text-width)
   both-text-width)

Should guard-foreign-escape use `#:callback-exns?`?

Now that the #:callback-exns? option for _fun has been added (in racket/racket@bf8741e), maybe guard-foreign-escape should use it:

draw/draw-lib/racket/draw/unsafe/callback.rkt

Lines 7 to 18 in 253dbf8

    
           ;; The 'racket VM can handle concurrent callbacks in different Racket 
        
           ;; threads, because it copies the C stack in and out to implement 
        
           ;; threads. The 'chez-scheme VM cannot do that, so callbacks have to 
        
           ;; be atomic. Additional work is needed to allow erroe escapes; we 
        
           ;; assume that any error happens in an atomic callback that was 
        
           ;; triggered by a foreign call that disables interrupts (which seems 
        
           ;; like a fragile assumption!). 
        
           ;; 
        
           ;; Atomicity implies that a callback cannot read from or write to an 
        
           ;; arbitrary port, so we have to "sanitize" a port by adding an 
        
           ;; intermediary. Unfortunately, this means that reading from a port 
        
           ;; has to be eager.

Is it possible to display bitmap in a loop?

I am drawing bitmaps to the output like so

#lang racket

(require racket/draw)  

(define imageWidth 64)
(define imageHeight 64)

(define target (make-bitmap imageWidth imageHeight)) 
(define dc (new bitmap-dc% [bitmap target]))

(define (set-frame dc color)
  (send dc set-pen "black" 2 'solid)
  (send dc set-brush color 'solid)
)

(define (display-frame dc)
  (send dc draw-rectangle 0 0 imageWidth imageHeight)
  target
)

(set-frame dc (make-color 255 255 255))
(display-frame dc)

(set-frame dc (make-color 255 0 0))
(display-frame dc)

(set-frame dc (make-color 0 255 0))
(display-frame dc)

(set-frame dc (make-color 0 0 255))
(display-frame dc)

However if I try to loop and send the bitmap to the output like so I don't see anything

#lang racket

(require racket/draw)  

(define imageWidth 64)
(define imageHeight 64)

(define target (make-bitmap imageWidth imageHeight)) 
(define dc (new bitmap-dc% [bitmap target]))

(define (set-frame dc color)
  (send dc set-pen "black" 2 'solid)
  (send dc set-brush color 'solid)
)

(define (display-frame dc)
  (send dc draw-rectangle 0 0 imageWidth imageHeight)
  target
)

(for ([x (in-range 4)])
    (set-frame dc (make-color 255 0 0))
    (display-frame dc)
)

I am not sure why its not working, but I am sure I am just making some noobie mistake.

memcpy given #<eof> in read-png-bytes

Loading the attached file causes the following error in DrRacket v8.2 [cs]:

memcpy: contract violation
  expected: exact-nonnegative-integer?
  given: #<eof>

context:
  (read-png-bytes . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/draw-lib/racket/draw/unsafe/png.rkt> 228 0 9596 169))
  (read-png . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/draw-lib/racket/draw/unsafe/png.rkt> 328 0 14170 620))
  (|do-load-bitmap/dispatch/known method in bitmap%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/draw-lib/racket/draw/private/bitmap.rkt> 454 4 16403 648))
  (|do-load-bitmap/port method in bitmap%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/draw-lib/racket/draw/private/bitmap.rkt> 423 4 14973 1116))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/draw-lib/racket/draw/private/syntax.rkt> 234 25 9144 19))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/draw-lib/racket/draw/private/bitmap.rkt> 169 2 4792 42346))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (do-make-object/real-class . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3581 0 194297 1099))
  (|load-file method in image-snip%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/snip-lib/racket/snip/private/snip.rkt> 1099 2 39480 2600))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (do-make-object/real-class . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3581 0 194297 1099))
  (|read method in image-snip-class%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/snip-lib/racket/snip/private/snip.rkt> 820 2 29301 2758))
  (|read-snips-from-file method in editor%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/wxme/editor.rkt> 606 2 20616 8597))
  (|do-read-from-file method in text%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/wxme/text.rkt> 2821 2 132288 583))
  (|do-insert-file method in text%| . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/wxme/text.rkt> 2736 2 128336 2697))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/editor.rkt> 238 23 8905 1268))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/editor.rkt> 225 19 8223 2280))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/framework/private/editor-misc.rkt> 127 10 5004 644))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/framework/private/frame.rkt> 1408 2 55910 9283))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/framework/private/frame.rkt> 762 2 30458 7931))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/framework/private/frame.rkt> 1058 2 42186 11053))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/framework/private/frame.rkt> 256 2 9082 7172))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/frame.rkt> 814 4 34087 1456))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/unit.rkt> 1411 4 64079 169500))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/module-language.rkt> 1620 4 74932 16237))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/debug.rkt> 1844 4 77409 7759))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/module-language-tools.rkt> 88 4 3392 5267))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/syncheck/gui.rkt> 2110 6 107995 25119))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/gui-debugger/debug-tool.rkt> 1169 6 56967 21765))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/macro-debugger/tool.rkt> 120 6 3595 11521))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/quickscript/tool.rkt> 94 6 2796 12976))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/deinprogramm-signature/deinprogramm/signature/tool.rkt> 18 6 412 2572))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/htdp-lib/stepper/xml-tool.rkt> 339 8 13619 3018))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/htdp-lib/stepper/stepper-tool.rkt> 173 2 5725 2601))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/htdp-lib/test-engine/test-tool.rkt> 68 6 2399 5471))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/htdp-lib/xml/text-box-tool.rkt> 21 5 397 646))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (continue-make-object . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3607 0 195511 2890))
  (do-make-object/real-class . #(struct:srcloc #<path:/usr/local/racket/collects/racket/private/class-internal.rkt> 3581 0 194297 1099))
  (create-new-drscheme-frame . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/unit.rkt> 5640 2 260334 393))
  (#f . #(struct:srcloc #<path:/usr/local/racket/collects/racket/contract/private/arrow-higher-order.rkt> 375 33 20717 125))
  (#f . #(struct:srcloc #<path:/usr/local/racket/collects/racket/contract/private/arrow-val-first.rkt> 489 18 20850 36))
  (#f . #(struct:srcloc #<path:/usr/local/racket/collects/racket/contract/private/arrow-val-first.rkt> 489 18 20850 36))
  (loop . #(struct:srcloc ".../private/map.rkt" 40 19 1374 258))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/drracket/drracket/private/main.rkt> 908 1 38354 1991))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/wx/common/queue.rkt> 435 6 19067 1056))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/wx/common/queue.rkt> 486 32 21054 120))
  (#f . #(struct:srcloc #<path:/usr/local/racket/share/pkgs/gui-lib/mred/private/wx/common/queue.rkt> 634 3 26076 58))

Rotating circles

The program below draws a rotating circle drawn with black outline and white interior on a gray background.
The circle has has center in the rotation center, so the expected result is a static image.
However the smoothing settings 'unsmoothed and 'aligned reveals a problem.
Using 'unsmoothed the outline pulses (the thickness varies).
Using 'aligned one sees the brush color "bleed" through the outline.

#lang racket/base
(require racket/gui)

(define width  640)
(define height 360)

(define angle 0.0) ; the rotation angle

; A frame containing a single canvas with a timer that continously calls draw.
(define top-frame  #f)
(define top-canvas #f)
(define top-timer  #f)

(define dc #f) ; drawing context of the canvas

(define red-pen
  (new pen%	 	 	 	 
       [color  "red"]	 	 	 	 
       [width  4]
       [style  'solid]
       [cap    'round]
       [join   'round]
       [stipple #f]))

(define black-pen
  (new pen%	 	 	 	 
       [color  "black"]
       [width  1]
       [style  'solid]
       [cap    'round]
       [join   'round]
       [stipple #f]))

(define white-pen
  (new pen%	 	 	 	 
       [color  "white"]	 	 	 	 
       [width  1]
       [style  'solid]
       [cap    'round]
       [join   'round]
       [stipple #f]))

(define white-brush (new brush% [color "black"]))



(define (draw)
  (define old-transformation #f)
  (when dc
    (send dc set-background "darkgray")
    (send dc clear)
    ; (send dc set-smoothing 'smoothed)   ; looks ok
    (send dc set-smoothing 'unsmoothed)   ; outline pulses
    ; (send dc set-smoothing 'aligned)    ; outline is slightly off
     
    (send dc set-pen white-pen)
    (send dc set-text-foreground "white")
        
    (set! old-transformation (send dc get-transformation))
    (send dc translate 440.5 180.5)
    (send dc rotate angle)

    (send dc set-brush white-brush)
    (send dc draw-ellipse -50 -50 100 100)
    (send dc set-transformation old-transformation)
    (set! angle (+ angle 0.025))))


(define my-frame%
  (class frame%
    (define/augment (on-close)
      (when top-timer
        (send top-timer stop)))
    (super-new)))


(define my-canvas%
  (class canvas%
    (define/override (on-paint)   ; repaint (exposed or resized)
      (define dc (send this get-dc))
      (send this suspend-flush)
      (handle-on-paint dc)
      (send this resume-flush))
    (super-new)))


(define (start-gui)
  (define frame  (new my-frame%
                      [label "sketch"]))
  (set! top-frame frame)  
  (define canvas (new my-canvas%
                      [parent     frame]
                      [min-width  width]
                      [min-height height]))
  (set! top-canvas canvas)
  (set! dc (send top-canvas get-dc))

  (define timer (new timer%
                     [notify-callback handle-on-timer]
                     [interval (inexact->exact (floor (/ 1000 30)))])) ; milliseconds
  (set! top-timer timer)
  
  (send frame show #t))

(define (handle-on-paint dc)  
  (when dc 
    (draw)))

(define (handle-on-timer)
  (send top-canvas on-paint))

(start-gui)

Pango AppKit workaround for CS and/or Aarch64?

There is a workaround here to prevent a problem with Pango's Core Text backed by loading AppKit, but it is specific to "x86_64-macosx/3m":

draw/draw-lib/racket/draw/unsafe/pango.rkt

Lines 49 to 55 in 253dbf8

    
           ;; Pango's Core Text back-end can somehow go wrong if we're going to eventually 
        
           ;; use AppKit but don't load AppKit it before using functions such as 
        
           ;; `pango_cairo_font_map_get_default'. So, force AppKit now for the platform 
        
           ;; where the Core Text back-end is used: 
        
           (when (equal? "x86_64-macosx/3m" 
        
                         (path->string (system-library-subpath))) 
        
             (void (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit"))))

Perhaps it should use (system-type 'os) or 'os* to also apply to, say, "aarch64-macosx/cs"? Or maybe the underlying problem has been fixed?

Emoji error when using macro stepper

Steps to reproduce:

raco macro-stepper file.rkt where file.rkt is:

#lang racket
(struct a ())

Click "End".

The following error would appear:

cairo_quartz_get_cg_context_with_clip: implementation not found; arguments: #<cpointer>
  context...:
   /Users/sorawee/projects/racket/racket/share/pkgs/draw-lib/racket/draw/private/emoji.rkt:159:7: draw-loop
   /Users/sorawee/projects/racket/racket/share/pkgs/draw-lib/racket/draw/private/dc.rkt:1457:4: do-text method in dc%
...
internal error: attempt to deschedule the current thread in atomic mode
  context...:
   /Users/sorawee/projects/racket/extra-pkgs/gui/gui-lib/mred/private/wx/common/queue.rkt:634:3
...
internal error: terminated in atomic mode!

I'm using Mac M1.

`draw-bitmap` ignores smoothing when the bitmap has a backing scale greater than 1.0 (at least on macOS)

On my machine, macOS 10.13.6, the draw-bitmap method of bitmap-dc% appears to ignore the current smoothing setting if the bitmap to be drawn has a backing scale greater than 1.0. This program reproduces the problem:

#lang racket

(require racket/draw)

(define (make-point-bitmap backing-scale)
  (define bmp (make-bitmap 3 3 #:backing-scale backing-scale))
  (define dc (new bitmap-dc% [bitmap bmp]))
  (send dc set-smoothing 'unsmoothed)
  (send dc draw-point 1.5 1.5)
  bmp)

(define (blow-up bmp scale)
  (define bmp* (make-bitmap (* (send bmp get-width) scale)
                            (* (send bmp get-height) scale)))
  (define dc (new bitmap-dc% [bitmap bmp*]))
  (send dc set-smoothing 'unsmoothed)
  (send dc set-scale scale scale)
  (send dc draw-bitmap bmp 0 0)
  bmp*)

(send (blow-up (make-point-bitmap 1.0) 100) save-file "blown-up-1.png" 'png)
(send (blow-up (make-point-bitmap 2.0) 100) save-file "blown-up-2.png" 'png)

The program produces the following images as output:

I would expect them to be the same, but the second is antialiased while the first one isn’t.

Possible bug?

While reading draw/private/dc I saw a line that may or may not be a bug.

In make-pattern-surface a new surface s is created.
Then a cairo context cr2 is created and a few settings are made using cr2.
But in line 868 the setting is made to cr and not cr2.
I am wondering whether this was on purpose?

https://github.com/racket/draw/blob/master/draw-lib/racket/draw/private/dc.rkt#L868

Feature request: `make-bitmap` method of `dc<%>`

I would like to request that a make-bitmap method be added to dc<%>. I would like it to behave like the existing make-bitmap function, with the following differences:

The backing scale is automatically inherited from the dc it is created from, and
it automatically chooses between make-bitmap, make-platform-bitmap, and make-screen-bitmap depending on what is most appropriate for the drawing context (if relevant).

For example, the drawing context produced by the get-dc method of canvas<%> would presumably use make-screen-bitmap to create a bitmap, while drawing contexts that don’t actually draw to bitmaps like post-script-dc% and record-dc% would just return a bitmap created with the make-bitmap function. Instances of bitmap-dc% would create bitmaps with the same properties as the currently-installed bitmap.

This would make it significantly easier for functions like blur from pict to do the right thing, avoiding bugs like racket/pict#52. I’m not sure it’s currently even possible to handle the second point with the existing interface.

Determine if source image has alpha channel

The procedure (send a-bitmap has-alpha-channel?) led me to believe that it would report whether the loaded image has an alpha channel, but apparently it only says whether the bitmap has been created with an alpha channel or not. I would like to request a feature that determines whether a source image has an alpha channel.

I was told that 'unknown/mask would only produce a mask if the source image had an alpha channel, but that is not the case - 'unknown/mask always produces a mask, it's just the mask will be completely black if there is no alpha.

racket/draw draw-text ignores kerning

What version of Racket are you using?
8.7 [cs]

What program did you run?

#lang racket/gui

(define (frame-label area)
  (let ((p (send area get-parent)))
    (if p
        (frame-label p)
        (send area get-label))))

(define hello%
  (class canvas%
    (init parent)
    (super-new (parent parent))

    (let ((dc (send this get-dc)))
      (send dc set-font (make-font #:size 80 #:face "Latin Modern Roman"))
      (send dc set-pen "black" 0 'solid)
      (send dc set-smoothing 'unsmoothed)
      (send dc set-brush "white" 'transparent))

    (define/public (draw-text-center text bounding-box baseline)
      (let ((dc (send this get-dc)))
        (let*-values ([(dc-width dc-height) (send dc get-size)]
                      [(text-width text-height baseline-height extra-height)
                       (send dc get-text-extent text)])
          (let* ((offset-x (/ (- dc-width text-width) 2))
                 (offset-y (/ (- dc-height text-height) 2))
                 (baseline-y (- (+ offset-y text-height) baseline-height))
                 (margin-x (- (+ offset-x text-width) 1)))
            (send dc draw-text text offset-x offset-y)
            (when bounding-box
              (send dc draw-rectangle offset-x offset-y text-width text-height))
            (when baseline
              (send dc draw-line offset-x baseline-y margin-x baseline-y))))))

    (define/override (on-paint)
      (send this draw-text-center (frame-label this) #t #t))
    ))

(define frame (new frame%
                   [label "Hello, World!"]
                   [width 700]
                   [height 200]))

(define hello (new hello% [parent frame]))

(send frame show #t)

What should have happened?
The following is a comparison between the text rendered by Inkscape (top) and the way the above program renders the text (bottom).

You can see the gap between the "W" and the "o" is too big.

If you got an error message, please include it here.
none

Please include any other relevant details
OS: Debian GNU/Linux 12 (bookworm)
I have discussed it in the Racket forum.

`draw-text` with `combine?` = `#t` missplaces diacritics.

The combine? argument to draw-text seems to shift circumflexes one character space to the left. The program:

#lang racket
(require racket/draw)
(define (draw t combine?)
  (define b (make-object bitmap% 100 100))
  (define dc (send b make-dc))
  (send dc translate 20 20)
  (send dc scale 5 5)
  (send dc draw-text t 0 0 combine?)
  b)

Produces:

A font% does not contain the leading

The distance between two text lines are called "leading".
In most fonts a recommended leading is part of the font.

Currently, there is method of font% that computes the leading.

GIF loading failure

I have a GIF file I'm trying to load into a bitmap and I get this failure:

> (define img (build-path "003.gif"))
> (define bmp
    (let ([in (open-input-file img)])
      (define bitmap (make-object bitmap% in 'gif/alpha))
      (close-input-port in)
      bitmap))
; vector-set!: index is out of range
;   index: 4096
;   valid range: [0, 4095]
;   vector: '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
;     -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1...
; [,bt for context]
> ,bt
; vector-set!: index is out of range
;   index: 4096
;   valid range: [0, 4095]
;   vector: '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1...
;   context...:
;    /usr/share/racket/pkgs/draw-lib/racket/draw/private/lzw.rkt:124:6: loop
;    /usr/share/racket/pkgs/draw-lib/racket/draw/gif.rkt:113:0: read-image
;    /usr/share/racket/pkgs/draw-lib/racket/draw/gif.rkt:141:6: loop
;    /usr/share/racket/pkgs/draw-lib/racket/draw/gif.rkt:128:0: read-gif
;    /usr/share/racket/pkgs/draw-lib/racket/draw/gif.rkt:182:0: gif->rgba-rows
;    /usr/share/racket/pkgs/draw-lib/racket/draw/private/bitmap.rkt:381:4: do-load-bitmap method in bitmap%
;    /usr/share/racket/pkgs/draw-lib/racket/draw/private/syntax.rkt:234:25
;    /usr/share/racket/pkgs/draw-lib/racket/draw/private/bitmap.rkt:156:2
;    /usr/share/racket/collects/racket/private/class-internal.rkt:3553:0: continue-make-object
;    /usr/share/racket/collects/racket/private/class-internal.rkt:3553:0: continue-make-object
;    /usr/share/racket/collects/racket/private/class-internal.rkt:3507:0: do-make-object
;    /usr/share/racket/pkgs/xrepl-lib/xrepl/xrepl.rkt:1443:0
; /usr/share/racket/collects/racket/private/misc.rkt:88:7

It appears to be a problem with gif->rgba-rows, but I'm not familiar enough with the internals to say for sure. For reference, here's the GIF I'm using.

Bugs caused by internally constructed objects

Some time ago I did a deep dive into the racket/draw contracts. Here is an observation that led me to some bugs: class contracts do not provide a guarantee on objects that are created from within the contract boundary.

Example 1

The numbers given to in-region? are expected to be real?. If you give imaginary numbers

(define reg (new region%))
(send reg in-region? 0+i 0+i)

the correct error from the region% class contract is raised:

; in-region?: contract violation
;   expected: real?
;   given: 0+1i
;   in: the 1st argument of
;       the in-region? method in
;       region%/c

However, regions can be created indirectly via the clipping region

(define r-dc (new record-dc%))
(send r-dc set-clipping-rect 0 0 550 400)
(define reg (send r-dc get-clipping-region))
(send reg in-region? 0+i 0+i)

and such will give an internal error since the region was not created through the protected region% class:

; cairo_in_fill: given value does not fit primitive C type
;   C type: _double*
;   value: 0.0+1.0i

Example 2

The fifth argument to get-argb-pixels is expected to be bytes?

(define bmp (make-bitmap 550 400))
(send bmp get-argb-pixels 0 0 0 0 #f)

and gives an error as such

; get-argb-pixels: contract violation
;   expected: bytes?
;   given: #f
;   in: an and/c case of
;       the 5th argument of
;       the get-argb-pixels method in
;       the range of ...

But bitmaps can be created through the make-bitmap method of canvases

(define frame (new frame% [label "Example"]))
(define canvas (new canvas% [parent frame]))
(define bmp (send canvas make-bitmap 550 400))
(send bmp get-argb-pixels 0 0 0 0 #f)

and in such a case an internal error is raised because it's unprotected

; bytes-length: contract violation
;   expected: bytes?
;   given: #f

Example 3

The blink-caret method of snips expects a dc<%>

(define sn (new snip%))
(send sn blink-caret #f #f #f)

and the contract gives this error

; blink-caret: contract violation
;   expected: (is-a?/c dc<%>)
;   given: #f
;   in: the 1st argument of
;       the blink-caret method in
;       the 2nd conjunct of ...

However, cloning the snip constructs a new object that is not protected

(define sn (new snip%))
(define sn2 (send sn copy))
(send sn2 blink-caret #f #f #f)

and gives this different error

; blink-caret method of snip%: expected argument of type <dc<%> instance>; given: #f; other arguments: #f #f

which doesn't come from a contract check, but is a (usually redundant) defensive check that is present in the blink-caret method.

Summary

These are just a few instances I found in racket/draw—there are probably quite a few more. I'm not sure what the takeaway is. My thought is that using (is-a?/c my-class%) and then subsequently assuming that objects satisfy the class contract on my-class% is dangerous since it assumes that my-class% objects are only constructed through the protected constructor. Using object/c contracts everywhere instead of is-a?/c isn't a panacea either because, as far as I know, they will not get collapsed and wrappers might quickly accumulate. So while these bugs that I mentioned can be fixed individually, I feel as though there is a deeper concern here with respect to class contracts in general.

Odd baseline for text drawn with `'swiss` on when that means Nimbus Sans

When I render the following 2htdp/image expression:

(overlay (text "3" 120 "yellow") (square 120 "solid" "dark brown"))

I get a picture that looks like this:

Note that it's not centered. If an actual Helvetica font is used, it produces a centered 3. Also if I use some other font like 'default, it works correctly:

To understand why, consider this program:

  (require racket/draw)
  (define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))
  (define ft (send the-font-list find-or-create-font 120 'swiss 'normal 'normal #f 'default #t))
  (send text-sizing-bm get-text-extent "3" ft)

This produces (values 67.0 121.0 33.0 0.0) on my machine but (values 67.0 139.0 27.0 0.0) on a different machine (thanks @ccshan) with Helvetica installed.

It's not clear to me what the bug is here but the drawing definitely seems wrong.

manual class sections lack a <h3> title

Class sections lack a <h3> title

neither
@include-section["color-class.scrbl"] in https://github.com/racket/draw/blob/master/draw-doc/scribblings/draw/draw.scrbl
or @defclass/title[color% object% ()]{ in https://github.com/racket/draw/blob/master/draw-doc/scribblings/draw/color-class.scrbl
does not cause a title for the section to be generated

but the first section 1. Overview does have a title

https://github.com/racket/draw/blob/master/draw-doc/scribblings/draw/guide.scrbl
@title[#:tag "overview"]{Overview}

As I wrote this issue I found

This form is normally used to create a section to be rendered on its own HTML. The 'hidden style is used because the definition box serves as a title.

https://docs.racket-lang.org/scribble/doc-classes.html#%28form._%28%28lib._scribble%2Fmanual..rkt%29._defclass%2Ftitle%29%29

So maybe this is intentional?

I'd prefer a <h3> heading "6 class%" followed by the definition box but I'm guessing that adding @title[#:tag "color%"]{color%} is the wrong way to achieve this. (I'm assuming it is desirable)

The other option would be to change
(list* (title #:style 'hidden (to-element (decl-name decl)))
to
(list* (title #:style #f (to-element (decl-name decl)))
but that would also affect defmixin/title and definterface/title.

PS I noticed this because I went looking to click the title to find the manual source like I could do for section 1:

there is a 6.1 Equality heading

there is no 6 colour% heading

get-recorded-procedure on record-dc seems to drop `set-clipping-rect`

This is not a regression from 7.4.

The program:

#lang racket
(require pict racket/draw)

(define (thing dc)
  (define b (send dc get-brush))
  (send dc set-brush "black" 'solid)
  (send dc draw-rectangle 0 0 100 100)
  (send dc set-brush b)
  ;; whiteout
  (define r (send dc get-clipping-region))
  (send dc set-clipping-rect 0 0 50 50)
  (send dc erase)
  (send dc set-clipping-region r))


(define bit (make-object bitmap% 100 100))
(thing (send bit make-dc))
bit

(define dc2 (new record-dc% [width 100] [height 100]))
(thing dc2)
(send dc2 get-recorded-datum)


(define x (send dc2 get-recorded-procedure))
(define bit1 (make-object bitmap% 100 100))
(x (send bit1 make-dc))
bit1

Produces the following in drracket:

The first image is what I would expect. The second image seems to be the result of the clipping rect not being set. (In general, any drawing I do after calling erase still happens). Oddly the call to set-clipping-region that corrisponds to set-clipping-rect appears in the recorded datum.

get-text-extent errors for a bitmap-dc% object without a bitmap installed

Hi! 👋
Found an inconsistency with current behavior and the docs, thought it was worth making an issue.

Per the documentation at https://docs.racket-lang.org/draw/bitmap-dc_.html

A bitmap% object must be supplied at initialization or installed into a bitmap DC using set-bitmap before any other method of the DC is called, except get-text-extent, get-char-height, or get-char-width. If any other bitmap-dc% method is called before a bitmap is selected, the method call is ignored.

Also in the docs for get-text-extent

Unlike most methods, this method can be called for a bitmap-dc% object without a bitmap installed.

However, when I try:

(define text-size-dc-unset (new bitmap-dc%))
(send text-size-dc-unset get-text-extent "Pickles")

I get an error:

get-text-extent in dc<%>: drawing context is not ok: (wrapper-object:bitmap-dc% ...)

Which probably comes from here:

draw/draw-lib/racket/draw/private/dc.rkt

Line 1363 in 01e00ba

(check-ok 'get-text-extent)

The other two methods, get-char-width and get-char-height work fine, its just this one :/

I'm using Racket v8.4 on a MacBook Pro (2019).

Why are "cornflowerblue" and "cornflower blue" different colors?

There are several places in racket/draw/private/color.rkt where two names differ by a space, but are defined as the same color. However, "cornflowerblue" and "cornflower blue" seem to break this pattern. Is there a reason why they are different?

Definition of "cornflowerblue":
https://github.com/racket/draw/blob/master/draw-lib/racket/draw/private/color.rkt#L143

 ("cornflowerblue" . #(100 149 237))

Definition of "cornflower blue":
https://github.com/racket/draw/blob/master/draw-lib/racket/draw/private/color.rkt#L249

 ("cornflower blue" . #(68 64 108))

It looks like "cornflowerblue" without the space has the same RGB values as the X11 cornflower blue on https://en.wikipedia.org/wiki/Cornflower_blue, so where do the RGB values for "cornflower blue" with the space come from? Is it a mistake or intentional?

Rotation and draw-text.

This example shows a rotating text.

Zooming in on the text (on macOS use ctrl and swipe up with two fingers to zoom in)
shows that the letters are "dancing". It looks as if each letter is rotated individually
instead of the text being drawn as a whole.

The expected result can be seen here (using p5.js):
https://processing.org/examples/textrotation.html

The example also shows that the thickness of the line varies.
Zoom in on the line and it becomes apparent that the line at some angles shrink in width.
In an animation this looks odd.

Turning on smoothing fixes the line thickness problem - but the reason for turning
it off was for speed.

Screen recording:

Screen.Recording.2021-07-01.at.14.22.31.mov

#lang racket/base
(require racket/gui)

(define width  640)
(define height 360)

(define angle 0.0) ; the rotation angle
(define (radians a) (* pi (/ a 180.)))

; A frame containing a single canvas with a timer that continously calls draw.
(define top-frame  #f)
(define top-canvas #f)
(define top-timer  #f)

(define dc #f) ; drawing context of the canvas

(define red-pen
  (new pen%	 	 	 	 
       [color  "red"]	 	 	 	 
       [width  4]
       [style  'solid]
       [cap    'round]
       [join   'round]
       [stipple #f]))

(define white-pen
  (new pen%	 	 	 	 
       [color  "white"]	 	 	 	 
       [width  1]
       [style  'solid]
       [cap    'round]
       [join   'round]
       [stipple #f]))

(define large-font
  (make-object font% 24 'modern))
       

(define (draw)
  (define old-transformation #f)
  (when dc
    (send dc set-background "black")
    (send dc clear)
    (send dc set-font large-font)
    ; (send dc set-smoothing 'smoothed)
    ; (send dc set-smoothing 'unsmoothed)    
    (send dc set-pen white-pen)
    (send dc set-text-foreground "white")
        
    (set! old-transformation (send dc get-transformation))
    (define angle1 (radians 45))
    (send dc translate 100.5 180.5)
    (send dc rotate angle1)
    (send dc draw-text "45 DEGREES" 0 0)
    (send dc draw-line 0 0 150 0)
    (send dc set-transformation old-transformation)

    (set! old-transformation (send dc get-transformation))
    (define angle2 (radians 270))
    (send dc translate 200.5 180.5)
    (send dc rotate angle2)
    (send dc draw-text "180 DEGREES" 0 0)
    (send dc draw-line 0 0 150 0)
    (send dc set-transformation old-transformation)

    (set! old-transformation (send dc get-transformation))
    (define angle3 (radians angle))
    (send dc translate 440.5 180.5)
    (send dc rotate angle3)
    (send dc draw-text (~a (modulo (inexact->exact (round angle)) 360) " DEGREES") 0 0)
    (send dc draw-line 0 0 150 0)
    (send dc set-transformation old-transformation)
    (set! angle (+ angle 0.25))

    (send dc set-pen red-pen)
    (send dc draw-point 100.5 180.5)
    (send dc draw-point 200.5 180.5)
    (send dc draw-point 440.5 180.5)))


(define my-frame%
  (class frame%
    (define/augment (on-close)
      (when top-timer
        (send top-timer stop)))
    (super-new)))


(define my-canvas%
  (class canvas%
    (define/override (on-paint)   ; repaint (exposed or resized)
      (define dc (send this get-dc))
      (send this suspend-flush)
      (handle-on-paint dc)
      (send this resume-flush))
    (super-new)))


(define (start-gui)
  (define frame  (new my-frame%
                      [label "sketch"]))
  (set! top-frame frame)  
  (define canvas (new my-canvas%
                      [parent     frame]
                      [min-width  width]
                      [min-height height]))
  (set! top-canvas canvas)
  (set! dc (send top-canvas get-dc))

  (define timer (new timer%
                     [notify-callback handle-on-timer]
                     [interval (inexact->exact (floor (/ 1000 30)))])) ; milliseconds
  (set! top-timer timer)
  
  (send frame show #t))

(define (handle-on-paint dc)  
  (when dc 
    (draw)))

(define (handle-on-timer)
  (send top-canvas on-paint))

(start-gui)

Pango warning printed out in Racket 7.6 CS

When I run the program below using racket.exe on a Windows machine, the warning below is printed out to the console. On a GUI application, a console window will open to print out this warning. This warning is only printed in the Chez version or Racket 7.6

Interestingly, the warning is not printed out when the code is run inside DrRacket, so it is disabled somehow, but I could not find how to disable this warning in my application.

This problem has existed in Racket 7.5 CS as well and I reported it on the racket-users list, but it was lost, so I am reporting here to keep track of the issue.

#lang racket
(require pict)
(text "Hello" '(bold . "Helvetica") 14)

$ racket text-h14.rkt
(racket.exe:59720): Pango-WARNING **: 15:12:31.361: couldn't load font "Helvetica Bold Not-Rotated 14px", falling back to "Sans Bold Not-Rotated 14px", expect ugly output.
#<pict>

Internal error when getting pen% and brush% color

I happened to try this while looking into racket/gui#307:

#lang racket/base

(require racket/class
         racket/draw)
(define p (new pen%))
(send p get-color)
(send p set-color "notacolor")
(send p get-color)

(object:color% ...)
get-color: broke its own contract
  promised: (is-a?/c color%)
  produced: #f
  in: the range of
      the get-color method in
      brush%/c
  contract from:
      <pkgs>/draw-lib/racket/draw.rkt
  contract on: brush%
  blaming: <pkgs>/draw-lib/racket/draw.rkt
   (assuming the contract is correct)
  at: <pkgs>/draw-lib/racket/draw.rkt:85:19
  context...:
   /Users/bogdan/sandbox/racket/racket/collects/racket/contract/private/blame.rkt:346:0: raise-blame-error
   .../private/arrow-higher-order.rkt:375:33
   body of "/var/folders/11/9c7x7y096r9g35f9th6b93qc0000gn/T/tmp.ArY5q8ZT/draw.rkt"

The brush% class has the same issue.

get-argb-pixels not enforcing contract causing segfault

@bennn and I have the following code that causes a segfault:

#lang racket/base

(require pict
         racket/class
         redex/reduction-semantics
         redex/pict)

(define-language nats
  [nat Z])

(define p (term->pict nats (term Z)))
(define b (pict->bitmap p))
(define w (pict-width p)) ; 105.7587890625 should be 106
(define h (pict-height p)) ; 14.2802734375 should be 15
(define pixbuf (make-bytes (* 4 (inexact->exact (ceiling (* w h))))))
(send b get-argb-pixels 0 0 w h pixbuf)
pixbuf

Looking at this, w and h are obviously wrong, and we should have gotten them with get-width and get-hight on the bitmap directly rather than getting them from the pict.

However, because we are passing non exact-nonnegative-integer? we would expect a contract violation, especially given the contract for the get-argb-pixels method:

    (get-argb-pixels (->*m
                       (exact-nonnegative-integer?
                        exact-nonnegative-integer?
                        exact-nonnegative-integer?
                        exact-nonnegative-integer?
                        (and/c bytes? (not/c immutable?)))
                       (any/c any/c #:unscaled? any/c)
                       void?))

However, what happens is we get a segfault.

Furthermore, if we pass in another incorrect value, say w=0.5 and h=0.5, rather than getting a segault, we just get a buffer filled with some data.

any form of dash seems broken if pen width is 1

If pen width is 1 and you use 'long-dash or any other variant, dashes are only drawn on the horizontal lines. If width is set to 2, they appear fine.

Repro is here, runs in drracket or racket-mode:

#lang racket/base

(require racket/draw
         racket/class)

(define (draw-box broken)
  (define canvas (make-bitmap 51 28))
  (define dc (send canvas make-dc))

  (send dc set-brush "WhiteSmoke" 'solid)

  (send dc set-pen "black"
        (if broken 1 2)                 ; BUG
        'long-dash)

  (send dc draw-rectangle 1 1 50 25)

  canvas)

(printf "BUG: only dashed on the sides:~n")
(draw-box 'broken)

(printf "correctly dashed, but needs to be 2x wide:~n")
(draw-box #f)

I can't track this down. The cairo binding code is really dense for me.

[Feature Request] Add draw-circle and draw-square methods to dc<%> in racket/draw

Is your feature request related to a problem? Please describe.
When using the racket/draw package, one often wants to draw a circle and square. This is done by using draw-ellipse and draw-rectangle, respectively, but this requires repeating information, which can clutter a codebase.

Describe the solution you'd like
The methods draw-circle and draw-square should be added to the dc<%> interface in the racket/draw library. The methods should simply defer to the draw-ellipse and draw-rectangle methods. Probably the only design decision would be whether draw-circle takes in a radius or diameter argument. I think radius is more natural but diameter is more consistent, being the "size" of the bounding box, with the rest of the racket/draw methods.

Describe alternatives you've considered
n/a

Do you want to contribute to this feature
I'm interested in helping out contributing this feature. I have not contributed to Racket before, but since this feature should be as straightforward as it gets (simply defer down to the existing draw-ellipse and draw-rectangle), it seems like a good one to start with. This is the main reason for me creating this feature request.

[Optional] Additional context
n/a

	;; The 'racket VM can handle concurrent callbacks in different Racket
	;; threads, because it copies the C stack in and out to implement
	;; threads. The 'chez-scheme VM cannot do that, so callbacks have to
	;; be atomic. Additional work is needed to allow erroe escapes; we
	;; assume that any error happens in an atomic callback that was
	;; triggered by a foreign call that disables interrupts (which seems
	;; like a fragile assumption!).
	;;
	;; Atomicity implies that a callback cannot read from or write to an
	;; arbitrary port, so we have to "sanitize" a port by adding an
	;; intermediary. Unfortunately, this means that reading from a port
	;; has to be eager.

	;; Pango's Core Text back-end can somehow go wrong if we're going to eventually
	;; use AppKit but don't load AppKit it before using functions such as
	;; `pango_cairo_font_map_get_default'. So, force AppKit now for the platform
	;; where the Core Text back-end is used:
	(when (equal? "x86_64-macosx/3m"
	(path->string (system-library-subpath)))
	(void (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit"))))