adjust the get-guidance dialog to have the more modern racket logo

racket · Oct 5, 2020 · 9cb6f43 · 9cb6f43
1 parent beb2c01
commit 9cb6f43
Show file tree

Hide file tree

Showing 3 changed files with 30 additions and 20 deletions.
diff --git a/drracket/drracket/private/drracket-normal.rkt b/drracket/drracket/private/drracket-normal.rkt
@@ -316,7 +316,8 @@
               (format "DrRacket ~a" (version))
               700
               #:allow-funny? #t
-              #:frame-icon todays-icon)
+              #:frame-icon (and (equal? (system-type) 'unix)
+                                (get-todays-icon)))
 
 (when (getenv "PLTDRBREAK")
   (printf "PLTDRBREAK: creating break frame\n") (flush-output)

diff --git a/drracket/drracket/private/frame-icon.rkt b/drracket/drracket/private/frame-icon.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 (require racket/class racket/draw (for-syntax racket/base racket/match racket/string xml))
-(provide todays-icon
+(provide get-todays-icon
          mb-scale-factor mb-main-drawing
          mb-flat-width mb-flat-height
          mb-plain-width mb-plain-height)
@@ -136,17 +136,20 @@
 (define mb-flat-width (inexact->exact (ceiling (* mb-plain-width mb-scale-factor))))
 (define mb-flat-height (inexact->exact (ceiling (* mb-plain-height mb-scale-factor))))
 
-(define todays-icon
-  (and (eq? (system-type) 'unix)
-       (let ()
-         (define bmp (make-object bitmap% mb-flat-width mb-flat-height #f #t))
-         (define dc  (make-object bitmap-dc% bmp))
-         (send dc set-smoothing 'smoothed)
-         (send dc set-pen "black" 1 'transparent)
-         (send dc set-brush "white" 'solid)
-         ;; draw white background circle to give color to lambda portion
-         (send dc draw-ellipse 2 2 (- mb-flat-width 4) (- mb-flat-height 4))
-         (send dc set-scale mb-scale-factor mb-scale-factor)
-         (mb-main-drawing dc)
-         (send dc set-bitmap #f)
-         bmp)))
+(define todays-icon #f)
+
+(define (get-todays-icon)
+  (unless todays-icon
+    (define bmp (make-object bitmap% mb-flat-width mb-flat-height #f #t))
+    (define dc  (make-object bitmap-dc% bmp))
+    (send dc set-smoothing 'smoothed)
+    (send dc set-pen "black" 1 'transparent)
+    (send dc set-brush "white" 'solid)
+    ;; draw white background circle to give color to lambda portion
+    (send dc draw-ellipse 2 2 (- mb-flat-width 4) (- mb-flat-height 4))
+    (send dc set-scale mb-scale-factor mb-scale-factor)
+    (mb-main-drawing dc)
+    (send dc set-bitmap #f)
+    (set! todays-icon bmp))
+  todays-icon)
+
diff --git a/drracket/drracket/private/language-configuration.rkt b/drracket/drracket/private/language-configuration.rkt
@@ -9,6 +9,7 @@
          drracket/private/drsig
          "tooltip.rkt"
          "local-member-names.rkt"
+         "frame-icon.rkt"
          string-constants
          framework
          framework/private/srcloc-panel
@@ -2358,7 +2359,8 @@
              (parent racketeer-panel)
              (label (string-constant racketeer?)))
         (new canvas-message% 
-             [label (read-bitmap (collection-file-path "plt-logo-red-shiny.png" "icons"))]
+             [label (get-todays-icon)]
+             [label-scale 2/3]
              [parent racketeer-panel]
              [callback (λ () (change-current-lang-to
                               (λ (x) (is-a? x drracket:module-language:module-language<%>))))])
@@ -2416,6 +2418,7 @@
       (define canvas-message%
         (class canvas%
           (init-field label
+                      [label-scale 1]
                       [font (get-font)]
                       [callback void]
                       [color #f])
@@ -2443,7 +2446,10 @@
                (send dc set-font old-font)
                (send dc set-text-foreground old-tf)]
               [(is-a? label bitmap%)
-               (send dc draw-bitmap label 0 0)]))
+               (define-values (x-scale y-scale) (send dc get-scale))
+               (send dc set-scale label-scale label-scale)
+               (send dc draw-bitmap label 0 0)
+               (send dc set-scale x-scale y-scale)]))
 
           (super-new [stretchable-width #f]
                      [stretchable-height #f]
@@ -2456,8 +2462,8 @@
              (min-width (inexact->exact (ceiling w)))
              (min-height (inexact->exact (ceiling h)))]
             [(is-a? label bitmap%)
-             (min-width (inexact->exact (ceiling (send label get-width))))
-             (min-height (inexact->exact (ceiling (send label get-height))))])))
+             (min-width (inexact->exact (ceiling (* label-scale (send label get-width)))))
+             (min-height (inexact->exact (ceiling (* label-scale (send label get-height)))))])))
 
       (define (question/answer line1 line2 icon-lst)
         (display-two-line-choice