a 'rendered by racket' logo

ibarland-image.rkt

#lang racket
(require 2htdp/image)
(provide (except-out (all-defined-out)
                     crop-text-image ; interface not yet finalized.
                     RX-DESCENDER
                     RX-ASCENDER
                     FONTS-WITH-SPACE-ABOVE
                     ))
(module+ test
  (require rackunit))


; scale-to-height : image image -> image
; Return `img` scaled to be as tall as `reference`.
; `img` must have non-zero height.
; 
(define (scale-to-height reference img)
  (when (zero? (image-height img))
    (error 'scale-to-height "Can't scale up a zero-height image, sorry."))
  (scale (/ (image-height reference) (image-height img)) img))

; scale-to-width : image image -> image
; Return `img` scaled to be as wide as `reference`.
; `img` must have non-zero width.
; 
(define (scale-to-width reference img)
  (when (zero? (image-height img))
    (error 'scale-to-width "Can't scale up a zero-width image, sorry."))
  (scale (/ (image-width reference) (image-width img)) img))

; above/fill-justify : (list-of image) -> image
; Place all `imgs` above each other, each fleshed out to the same width
; (the maximum of the original widths).
; Returns the empty-image is `imgs` is empty.
; None of the images can have zero-width (unless they all do).
;
(define (above/fill-justify . imgs)
  (cond [(empty? imgs) empty-image]
        [else (define w (apply max (map image-width imgs)))
              (if (zero? w)
                  (if (= 1 (length imgs)) (first imgs) (apply above imgs))
                  (for/fold {[so-far empty-image]}
                            {[img imgs]}
                    (above so-far (scale (if (zero? (image-width img))
                                             1
                                             (/ w (image-width img)))
                                         img))))]))

; beside/fill-justify : (list-of image) -> image
; Place all `imgs` beside each other, each fleshed out to the same height
; (the maximum of the original heights).
; Actually, the baseline is used instead of height (same in most instances,
; but works better for text).
; Returns the empty-image is `imgs` is empty.
; zero-height images are not scaled, but still included (preserves spacing.)
;
(define (beside/fill-justify . imgs)
  (cond [(empty? imgs) empty-image]
        [else (define w (apply max (map image-baseline imgs)))
              (if (zero? w)
                  (if (= 1 (length imgs)) (first imgs) (apply beside imgs))
                  (for/fold {[so-far empty-image]}
                            {[img imgs]}
                    #;(displayln (list ">" so-far "< so far; adding: " img "."))
                    (beside so-far (scale (if (zero? (image-height img))
                                              1
                                              (/ w (image-height img)))
                                          img))))]))


(module+ test
  (check-equal? (above/fill-justify (circle 20 'solid "red")
                                    (circle 40 'solid "green")
                                    (square 30 'solid  "blue"))
                (above (circle 40 'solid "red")
                       (circle 40 'solid "green")
                       (square (* 2 40) 'solid "blue")))
  (check-equal? (beside/fill-justify (circle 20 'solid "red")
                                     (circle 40 'solid "green")
                                     (square 30 'solid  "blue"))
                (beside (circle 40 'solid "red")
                        (circle 40 'solid "green")
                        (square (* 2 40) 'solid "blue")))
  
  (check-equal? (beside/fill-justify) empty-image)
  (check-equal? (above/fill-justify ) empty-image)
  
  (check-equal? (beside/fill-justify empty-image) empty-image)
  (check-equal? (beside/fill-justify empty-image
                                     (rectangle 10 0 'outline 'black)
                                     empty-image
                                     (circle 0 'solid 'red)
                                     empty-image) 
                (beside (rectangle 10 0 'outline 'black) (circle 0 'solid 'red)))
  
  (check-equal? (above/fill-justify empty-image) empty-image)
  (check-equal? (above/fill-justify empty-image 
                                    (rectangle 0 10 'outline 'black)
                                    empty-image
                                    (circle 0 'solid 'red)
                                    empty-image) 
                (above (rectangle 0 10 'outline 'black) (circle 0 'solid 'red)))
  
  (check-equal? (above/fill-justify empty-image
                                    (rectangle 10 0 'outline 'black)
                                    empty-image
                                    (circle 0 'solid 'red)
                                    empty-image)
                (rectangle 10 0 'outline 'black))
  (check-equal? (beside/fill-justify empty-image 
                                     (rectangle 0 10 'outline 'black)
                                     empty-image
                                     (circle 0 'solid 'red))
                (rectangle 0 10 'outline 'black))
  
  (define c1 (circle 20 'solid 'blue))
  (define r2 (rectangle 30 50 'solid 'red))
  (check-equal? (beside/fill-justify c1 (hspace 4) r2)
                (beside (scale (/ 50 40) c1) (hspace 4) r2))
  (check-equal? (beside/fill-justify c1 (hspace 4) (vspace 10) r2)
                (beside (scale (/ 50 40) c1) (hspace 4) r2))
  (check-equal? (beside/fill-justify c1 (hspace 4) (vspace 100) r2)
                (beside (scale (/ 100 40) c1) (hspace 4) (scale (/ 100 50) r2)))

  (check-equal? (above/fill-justify c1 (vspace 4) (hspace 10) r2)
                (above c1 (vspace 4) (scale (/ 40 30) r2)))
  (check-equal? (above/fill-justify c1 (vspace 4) (hspace 100) r2)
                (above (scale (/ 100 40) c1) (vspace 4) (scale (/ 100 30) r2)))
  )
                
; hspace : non-negative number -> image
; An invisible rectangle with width `sz`,
; suitable for horizontal spacing with `beside`.
;
(define (hspace sz) (rectangle sz 0 'solid 'transparent))
(module+ test
  (check-eqv? (image-width  (hspace 20)) 20)
  (check-eqv? (image-height (hspace 20)) 0)
  (check-eqv? (image-width  (vspace 20)) 0)
  (check-eqv? (image-height (vspace 20)) 20)
  (check-equal? (hspace 0) empty-image)
  (check-not-equal? (image-height (vspace 20)) empty-image)
  )

; vspace : non-negative number -> image
; An invisible rectangle with height `sz`,
; suitable for vertical spacing with `above`.
;
(define (vspace sz) (rectangle 0 sz 'solid 'transparent))
         
;;;;;;;;;;;;;;;

; TODO: improve for unicode:
(define RX-DESCENDER #rx"[Q,;_gjpqy]")
(define RX-ASCENDER #rx"[][A-Zbdfhijklt!@#$%^&*()\\|]")
; Fonts that have space above the ascenders (equal to the space below the baseline).
;
(define FONTS-WITH-SPACE-ABOVE '("Open Sans"))



; crop-text-image : boolean, boolean, image -> image
; Given an image (presumably of text), crop away space below the baseline
; unless `has-descenders?`.
; 
; Also, fonts in FONTS-WITH-SPACE-ABOVE have space above their ascenders (if any),
; so remove even more?
; OR: convert to a bit-map and search each column?!
; This generalizes to all images, and works for all fonts.
; But it means knowing what background-color is croppable;
; however, `text` makes the background transparent, so not a problem there.
;
(define (crop-text-image has-descenders? txt)
  (define h (image-height txt))
  (define possible-margin (- h (image-baseline txt)))
  (define top-margin possible-margin)
  ; Even if there are ascenders, some fonts have more space above?!
  ; (Looking at you, Open Sans.)
  (define bottom-margin (if has-descenders? 0 possible-margin))
  (crop 0 top-margin (image-width txt) (- h top-margin bottom-margin)  txt))

; text/font/cropped: as `text` from 2htdp/image, except
; that the result tries to crop away any unused descender/ascender space.
;
(define (text/cropped  string font-size color
                      #:has-descenders? [has-descenders?
                                         (regexp-match? RX-DESCENDER string)])
  (define original (text string font-size color))
  (crop-text-image has-descenders? original))


; text/font/cropped: as `text/font` from 2htdp/image, except
; that the result tries to crop away any unused descender/ascender space.
;
(define (text/font/cropped  string font-size color face family style weight underline?
                            #:has-descenders? [has-descenders?  (regexp-match? RX-DESCENDER string)])
  (define original (text/font  string font-size color face family style weight underline?))
  (crop-text-image has-descenders? original))


(define (frame/pad img pad)
  (frame (above (vspace              pad)
                (beside (hspace pad) img (hspace pad))
                (vspace              pad))))

rendered-by-racket.rkt

#lang racket

(require 2htdp/image)
(require "ibarland-image.rkt")
(define logo (bitmap icons/plt-48x48.png))



(define line1 (text/font/cropped "rendered by" 8 "black" "Open Sans" 'swiss 'italic 'light #f))
(define line2 (text/font/cropped "Racket" 14 "black" "Open Sans" 'swiss 'normal 'normal #f))

; make-logo : nonnegative-number -> image
; Make a logo, where `top-line-factor` adjusts how long `line1` is, relative to `line2`.
(define (make-logo top-line-factor)
  
  ; We could use above/fill-justify to stack these two lines, but it leaves more
  ; spaces than visually desired.  So, manually adjust the width, then overlay:
  ;
  (define line1-flush   (scale top-line-factor line1)
    ; Making the first two lines flush looks bad, too:
    #; (scale-to-width line2 line1) )
  ;
  ; NOTE: We can't scale text in *just* the x- or y- direction alone (using 2htdp/image).
  
  (define catchphrase
    (overlay/xy line1-flush 0 7 line2))
  ;
  ; The y-value (7) determined by experiment.
  ; This 'vertically kerns' the "y" of 'rendered by' above the 't' of 'Racket'.
  
  
  
  
  
  (define certificate (frame/pad (beside/fill-justify logo (hspace 4) catchphrase) 3))
  ;(displayln certificate)
  ;(displayln (scale 0.7 certificate))
  ;(displayln (scale 3 certificate))
  certificate
  )



(make-logo 0.83)