fable/fable.rkt
#lang racket
(require racket/runtime-path
         racket/gui/base
         slideshow/play
         slideshow
         "../color.rkt"
         "../util.rkt")
(define-runtime-path fable.txt "fable.txt")
(define-runtime-path here ".")

(provide fable)

(define orig-csa (current-slide-assembler))

(define (black-assembler title sep p)
  (ct-superimpose (inset (colorize (filled-rectangle 1024 768) "black")
                         (- margin))
                  p))

(define-syntax-rule
  (ns n ...)
  (colorize
   (parameterize ([current-font-size 12])
     (hbl-append (t (format "~s = ~s  " 'n n)) ...))
   "white"))

(define (fable)
  (current-slide-assembler black-assembler)
  
  (play-n
   #:steps (build-list 12 (λ (i) (if (= i 11) 50 10)))
   fable-animation-func)
  
  (current-slide-assembler orig-csa))

(define (fable-animation-func n0 n1 n2 n4 n5 n6 n8 n9 n10 n11 n12 n14)
  (define main
    (if (= n14 1) 
        cached-main
        (build-main n0 n1 n2 n4 n5 n6 n8 n9 n10 n11 n12)))
  (scroll-up-picts
   (list main (cc-superimpose moral (blank 0 (pict-height main))))
   (list n14)))

(define (build-main n0 n1 n2 n4 n5 n6 n8 n9 n10 n11 n12)
  (evenize
   (ct-superimpose
    (title-animation n0)
    ((if (= n0 1) values ghost) 
     (vc-append
      (blank 0 80)
      (cc-superimpose
       (hc-append
        20
        (scroll-up-picts (list (scale (img 'koala) 2/3)
                               (scale (img 'happy-koala) 2/3)
                               (scale (img 'orangutan) 2/3)
                               (scale (img 'happy-orangutan) 2/3)
                               (scale (img 'walrus) 2/3))
                         (list n4 n5 n10 n11))
        (scroll-up-picts (list ftp-example
                               (if (n6 . > . 0)
                                   (colorize (buggy-c-code) "white")
                                   (colorize c-code "white"))
                               (if (n12 . > . 0)
                                   (colorize (latex-code values ghost) "white")
                                   (colorize (latex-code ghost values) "white")))
                         (list n1 n8)))
       ((if (zero? n4) values ghost)
        (blink n2 (img 'duncan)))
       ((if (zero? n10) values ghost)
        (blink n9 (img 'lucy-surprise))))
      (blank 0 10)
      (lines (parse-fable) (list n1 n2 n4 n5 n6 n8 n9 n10 n11 n12)))))))
  
(define (lines strs ns)
  (define first-zero? #t)
  (apply
   ctl-superimpose
   (for/list ([str (in-list strs)]
              [n (in-list (append ns '(0)))])
     ((cond
        [(and (zero? n) first-zero?)
         (set! first-zero? #f)
         values]
        [else
         ghost])
      (parameterize ([current-font-size 16])
        (colorize (para #:width 900 str) "white"))))))

(define (parse-fable)
  (define sp (open-output-string))
  (call-with-input-file fable.txt
    (λ (port)
      (copy-port port sp)))
  (define fable1 (get-output-string sp))
  (define fable2 (regexp-split #rx"\n\n" fable1))
  (define fable3 (map (λ (x) (regexp-replace* #rx"\n" x " "))
                      fable2))
  (define fable4 (map (λ (x) (regexp-replace* #rx"  +" x " "))
                      fable3))
  ;; drop the title
  (cdr fable4))

(define image-specs
  '(("koala.jpg" 1)
    ("duncan.jpg" 1)
    ("happy-koala.jpg" 1)
    ("orangutan.jpg" 1)
    ("lucy-surprise.jpg" 1)
    ("happy-orangutan.jpg" 1)
    ("walrus.jpg" 1)))

(define images (make-hash))

(for ([i (in-list image-specs)])
  (define key (string->symbol (regexp-replace #rx"[.](.*)" (list-ref i 0) "")))
  (hash-set! images
             key
             (scale (bitmap (read-bitmap (build-path here (list-ref i 0))))
                    (list-ref i 1))))
(define (img k) 
  (hash-set! used k #f)
  (hash-ref images k))
(define used (make-hash))

(define image-spacer (ghost (apply cc-superimpose (hash-map images (λ (x y) y)))))

(define (title-animation n0)
  (define start-h (- (/ client-h 2) 
                     (/ (pict-height start-title1) 2)))
  (define end-h 20)
    
  (define-values (title1 title2 title3) (fable-title n0))
  
  (slide-pict
   (slide-pict
    (slide-pict
     (ct-superimpose (vc-append 40
                                (parameterize ([current-font-size end-size])
                                  (hbl-append end-title1
                                              (t " ")
                                              end-title2
                                              (t " ")
                                              end-title3)))
                     (vl-append start-title1
                                start-title2
                                start-title3))
     title3
     start-title3
     end-title3
     n0)
    title2
    start-title2
    end-title2
    n0)
   title1
   start-title1
   end-title1
   n0))

(define start-size 127)
(define end-size 50)


(define (fable-title n) 
  (parameterize ([current-font-size (between start-size end-size n)])
    (values 
     (colorize (t "The Koala,") "white")
     (colorize (t "the Orangutan,") "white")
     (colorize (t "and the Walrus") "white"))))
(define (between start-size end-size n)
  (round (inexact->exact (+ start-size (* n (- end-size start-size))))))

(define (ghost3 f x)
  (define-values (a b c) (f x))
  (values (ghost a) (ghost b) (ghost c)))
(define-values (start-title1 start-title2 start-title3) (ghost3 fable-title 0))
(define-values (end-title1 end-title2 end-title3) (ghost3 fable-title 1.0))

(define c-code
  (vl-append
   (tt "int main () {")
   (tt "  if (!(q = 0))")
   (tt "    *((int*)p)=12;")
   (tt "}")))

(define bad-tau2 (tt "\\tau_2"))

(define (latex-code fix bug)
  (vl-append
   (tt "\\[\\Gamma\\ \\vdash\\")
   (hbl-append (tt "  (\\lambda x:")
               (lbl-superimpose (bug (tt "\\tau_2"))
                                (fix (colorize (tt "\\tau_2") light-red)))
               (tt ".e)"))
   (tt "   : \\tau_1\\rightarrow")
   (tt "     \\tau_2 \\]")))

(define (buggy-c-code)
  (rbl-superimpose
   c-code
   (colorize (tt "p == 0 ∨ *p == *q") light-red)))

(define ftp-example
  (colorize
   (vl-append
    (tt "ftp> user anonymous")
    (tt "331 Guest login ok")
    (tt "Password:")
    (tt "230-Welcome to λ.com"))
   "white"))

(define (pale-behind p)
  (cc-superimpose
   (cellophane (colorize (filled-rectangle (pict-width p) (pict-height p)) "black") .8)
   p))
   

(define (scroll-up-picts ps ns)
  (define bkg (ghost (apply cc-superimpose ps)))
  (define h (pict-height bkg))
  (define uniform-ps (for/list ([p (in-list ps)]) 
                       (cc-superimpose
                        (blank (pict-width bkg) 0)
                        (scale p (/ h (pict-height p))))))
  (define combined (apply vc-append uniform-ps))
  (define x 
    (apply
     +
     (for/list ([p (in-list ps)]
                [n (in-list ns)])
       (* n h))))
  (inset/clip combined 0 (- x) 0 (+ (- x (pict-height combined)) h -1)))

(define (blink n p)
  ((cond
     [(<= n .1) ghost]
     [(<= n .3) values]
     [(<= n .5) ghost]
     [(<= n .7) values]
     [(<= n .9) ghost]
     [else values])
   p))

(define moral
  (to-bitmap
   (evenize
    (colorize
     (let ([first-line 
            (scale/improve-new-text
             (parameterize ([current-font-size 60])
               (t "Moral: bugs are"))
             2)]
           [second-line-w (pict-width (bt "everywhere"))])
       (vc-append first-line
                  (scale/improve-new-text (bt "everywhere")
                                          (/ (pict-width first-line)
                                             second-line-w))))
     "white"))
   "black"
   #:no-alpha? #t))

(define uncached-main (build-main 1 1 1 1 1 1 1 1 1 1 1))

(define cached-main (to-bitmap uncached-main "black" #:no-alpha? #t))