From d9cb16de1e21a707c591c5288304fe2a055da2ca Mon Sep 17 00:00:00 2001 From: Daniel Feltey <dfeltey@gmail.com> Date: Wed, 9 Nov 2016 10:32:52 -0600 Subject: [PATCH] Add plt-title-background to slideshow --- slideshow-doc/info.rkt | 1 + .../slideshow/plt-title-background.scrbl | 37 +++ .../scribblings/slideshow/slides.scrbl | 1 + .../slideshow/plt-title-background.rkt | 218 ++++++++++++++++++ 4 files changed, 257 insertions(+) create mode 100644 slideshow-doc/scribblings/slideshow/plt-title-background.scrbl create mode 100644 slideshow-lib/slideshow/plt-title-background.rkt diff --git a/slideshow-doc/info.rkt b/slideshow-doc/info.rkt index 438a040..5c00d6d 100644 --- a/slideshow-doc/info.rkt +++ b/slideshow-doc/info.rkt @@ -9,6 +9,7 @@ "scribble-doc" "web-server-doc" "base" + "draw-lib" "gui-lib" "pict-lib" "scribble-lib" diff --git a/slideshow-doc/scribblings/slideshow/plt-title-background.scrbl b/slideshow-doc/scribblings/slideshow/plt-title-background.scrbl new file mode 100644 index 0000000..0179661 --- /dev/null +++ b/slideshow-doc/scribblings/slideshow/plt-title-background.scrbl @@ -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]} diff --git a/slideshow-doc/scribblings/slideshow/slides.scrbl b/slideshow-doc/scribblings/slideshow/slides.scrbl index 0105050..ce97c1f 100644 --- a/slideshow-doc/scribblings/slideshow/slides.scrbl +++ b/slideshow-doc/scribblings/slideshow/slides.scrbl @@ -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"] diff --git a/slideshow-lib/slideshow/plt-title-background.rkt b/slideshow-lib/slideshow/plt-title-background.rkt new file mode 100644 index 0000000..2fed86f --- /dev/null +++ b/slideshow-lib/slideshow/plt-title-background.rkt @@ -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)) + \ No newline at end of file