Skip to content

Add plt-title-background to slideshow #4

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add plt-title-background to slideshow #4

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions slideshow-doc/info.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
"scribble-doc"
"web-server-doc"
"base"
"draw-lib"
"gui-lib"
"pict-lib"
"scribble-lib"
Expand Down
37 changes: 37 additions & 0 deletions slideshow-doc/scribblings/slideshow/plt-title-background.scrbl
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,37 @@
#lang scribble/doc
@(require "ss.rkt" (for-label slideshow/plt-title-background pict pict/color racket/draw))

@title[#:tag "plt-background"]{PLT Title Background}

@defmodule[slideshow/plt-title-background]{
The @racketmodname[slideshow/plt-title-background] module provides
bindings for generating slide backgrounds with the PLT logo.}

@defthing[plt-title-background pict?]{
A rendering of the PLT logo on a pict the size of the client area.}

@defproc[(make-plt-title-background [width real? client-w]
[height real? client-h]
[red-color
(or/c color/c (-> (is-a?/c dc<%>) any))
plt-red-color]
[blue-color
(or/c color/c (-> (is-a?/c dc<%>) any))
plt-blue-color]
[background-color (or/c color/c #f) plt-background-color]
[lambda-color
(or/c color/c (-> (is-a?/c dc<%>) any) #f)
plt-lambda-color]
[pen-color color/c plt-pen-color]
[pen-style pen-style/c plt-pen-style]
[#:clip? clip? boolean? #t]
[#:edge-cleanup-pen edge-cleanup-pen (or/c (is-a?/c pen%) #f) #f])
pict?]{
Produces a pict of the PLT logo of the specified width, height, and colors.}

@defthing[plt-red-color color/c]{The default red color used by @racket[make-plt-title-background]]}
@defthing[plt-blue-color color/c]{The default blue color used by @racket[make-plt-title-background]}
@defthing[plt-background-color color/c]{The default background color used by @racket[make-plt-title-background]}
@defthing[plt-lambda-color color/c]{The default lambda color used by @racket[make-plt-title-background]}
@defthing[plt-pen-color color/c]{The default pen color used by @racket[make-plt-title-background]}
@defthing[plt-pen-style pen-style/c]{The default pen style used by @racket[make-plt-title-background]}
1 change: 1 addition & 0 deletions slideshow-doc/scribblings/slideshow/slides.scrbl
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -674,3 +674,4 @@ mode.
If @racket[stop-after] is not @racket[#f], then the list is truncated
after @racket[stop-after] slides are converted to picts.}

@include-section["plt-title-background.scrbl"]
218 changes: 218 additions & 0 deletions slideshow-lib/slideshow/plt-title-background.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,218 @@
#lang racket/base

(require "slide.rkt"
racket/gui/base
racket/class
racket/math)

(provide plt-title-background
make-plt-title-background
plt-red-color
plt-blue-color
plt-background-color
plt-lambda-color
plt-pen-color
plt-pen-style)

(define plt-red-color (make-object color% 242 183 183))
(define plt-blue-color (make-object color% 183 202 242))
(define plt-background-color (make-object color% 209 220 248))
(define plt-lambda-color (send the-color-database find-color "white"))
(define plt-pen-color "black")
(define plt-pen-style 'transparent)

(define (with-dc-settings dc thunk)
(let ([alpha (send dc get-alpha)]
[smoothing (send dc get-smoothing)]
[pen (send dc get-pen)]
[brush (send dc get-brush)])
(thunk)
(send dc set-alpha alpha)
(send dc set-smoothing smoothing)
(send dc set-pen pen)
(send dc set-brush brush)))

(define (make-plt-title-background [width (client-w)]
[height (client-h)]
[plt-red-color plt-red-color]
[plt-blue-color plt-blue-color]
[plt-background-color plt-background-color]
[plt-lambda-color plt-lambda-color]
[plt-pen-color plt-pen-color]
[plt-pen-style plt-pen-style]
#:clip? [clip? #t]
#:edge-cleanup-pen [edge-cleanup-pen #f])
(let ()
(define left-lambda-path
(let ([p (new dc-path%)])
(send p move-to 153 44)
(send p line-to 161.5 60)
(send p curve-to 202.5 49 230 42 245 61)
(send p curve-to 280.06 105.41 287.5 141 296.5 186)
(send p curve-to 301.12 209.08 299.11 223.38 293.96 244)
(send p curve-to 281.34 294.54 259.18 331.61 233.5 375)
(send p curve-to 198.21 434.63 164.68 505.6 125.5 564)
(send p line-to 135 572)
p))

(define left-logo-path
(let ([p (new dc-path%)])
(send p append left-lambda-path)
(send p arc 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f)
p))

(define bottom-lambda-path
(let ([p (new dc-path%)])
(send p move-to 135 572)
(send p line-to 188.5 564)
(send p curve-to 208.5 517 230.91 465.21 251 420)
(send p curve-to 267 384 278.5 348 296.5 312)
(send p curve-to 301.01 302.98 318 258 329 274)
(send p curve-to 338.89 288.39 351 314 358 332)
(send p curve-to 377.28 381.58 395.57 429.61 414 477)
(send p curve-to 428 513 436.5 540 449.5 573)
(send p line-to 465 580)
(send p line-to 529 545)
p))

(define bottom-logo-path
(let ([p (new dc-path%)])
(send p append bottom-lambda-path)
(send p arc 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f)
p))

(define right-lambda-path
(let ([p (new dc-path%)])
(send p move-to 153 44)
(send p curve-to 192.21 30.69 233.21 14.23 275 20)
(send p curve-to 328.6 27.4 350.23 103.08 364 151)
(send p curve-to 378.75 202.32 400.5 244 418 294)
(send p curve-to 446.56 375.6 494.5 456 530.5 537)
(send p line-to 529 545)
p))

(define right-logo-path
(let ([p (new dc-path%)])
(send p append right-lambda-path)
(send p arc 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t)
p))

(define lambda-path ;; the lambda by itself (no circle)
(let ([p (new dc-path%)])
(send p append left-lambda-path)
(send p append bottom-lambda-path)
(let ([t (make-object dc-path%)])
(send t append right-lambda-path)
(send t reverse)
(send p append t))
(send p close)
p))

;; This function draws the paths with suitable colors:
(define (paint-plt dc dx dy)
(send dc set-smoothing 'aligned)
(let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[old-clip (send dc get-clipping-region)])

(send dc set-pen plt-pen-color 0 plt-pen-style)

(cond
[(procedure? plt-lambda-color)
(with-dc-settings
dc
(λ ()
(plt-lambda-color dc)
(send dc draw-path lambda-path dx dy)))]
[plt-lambda-color
(send dc set-brush plt-lambda-color 'solid)
(send dc draw-path lambda-path dx dy)]
[else
(void)])

;; Draw red regions
(cond
[(is-a? plt-red-color bitmap%)
(let ([rgn1 (new region% [dc dc])]
[rgn2 (new region% [dc dc])])
(send rgn1 set-path left-logo-path dx dy)
(send rgn2 set-path bottom-logo-path dx dy)
(send rgn2 union rgn1)
(send dc set-clipping-region rgn2)

;; the left and top values of the bounding box seem to change over time,
;; so I've just put reasonable numbers below.
(let-values ([(sw sh) (send dc get-scale)])
(send dc set-scale 1 1)
(send dc draw-bitmap plt-red-color 220 100)
(send dc set-scale sw sh)))
(send dc set-clipping-region old-clip)
(cleanup-edges left-logo-path dc dx dy)
(cleanup-edges bottom-logo-path dc dx dy)]
[(procedure? plt-red-color)
(with-dc-settings
dc
(λ ()
(plt-red-color dc)
(send dc draw-path left-logo-path dx dy)
(send dc draw-path bottom-logo-path dx dy)))]
[else
(send dc set-brush plt-red-color 'solid)
(send dc draw-path left-logo-path dx dy)
(send dc draw-path bottom-logo-path dx dy)])

;; Draw blue region
(cond
[(is-a? plt-blue-color bitmap%)
(let ([rgn (new region% [dc dc])])
(send rgn set-path right-logo-path dx dy)
(send dc set-clipping-region rgn)

;; the left and top values of the bounding box seem to change over time,
;; so I've just put reasonable numbers below.
(let-values ([(sw sh) (send dc get-scale)])
(send dc set-scale 1 1)
(send dc draw-bitmap plt-blue-color 430 50)
(send dc set-scale sw sh))
(send dc set-clipping-region old-clip)
(cleanup-edges right-logo-path dc dx dy))]
[(procedure? plt-blue-color)
(with-dc-settings
dc
(λ ()
(plt-blue-color dc)
(send dc draw-path right-logo-path dx dy)))]
[else
(send dc set-brush plt-blue-color 'solid)
(send dc draw-path right-logo-path dx dy)])

(send dc set-pen old-pen)
(send dc set-brush old-brush)
(send dc set-clipping-region old-clip)))

(define (cleanup-edges path dc dx dy)
(when edge-cleanup-pen
(let ([pen (send dc get-pen)]
[brush (send dc get-brush)]
[alpha (send dc get-alpha)])
(send dc set-pen edge-cleanup-pen)
(send dc set-brush "black" 'transparent)
(send dc set-alpha .8)
(send dc draw-path path dx dy)
(send dc set-pen pen)
(send dc set-brush brush)
(send dc set-alpha alpha))))

((if clip? clip values)
(pin-over
(if plt-background-color
(colorize (filled-rectangle width height)
plt-background-color)
(blank width height))
320
50
(scale (dc paint-plt 630 630 0 0) 12/10)))))

(define plt-title-background
(make-plt-title-background))