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