(module core scheme/base
  (require scheme/class
           scheme/unit
           scheme/file
           racket/draw
           texpict/mrpict
           texpict/utils
           scheme/math
	   "sig.ss"
	   "private/utils.ss"
           "private/aspect.rkt")

  (provide core@ 
	   zero-inset)

  ;; We create structs just once, so that all instances of the 
  ;; core share the types.
  (define/provide-struct sliderec (drawer        ; dc<%> x y -> void
				   title         ; string
				   comment       ; #f or just-a-comment
				   page          ; int
				   page-count    ; int
				   inset         ; sinset
				   [transitions  ; canvas% bitmap% -> 'went or delay-msecs
                                    #:mutable]
                                   timeout       ; msecs
                                   aspect))      ; screen aspect: '3:4, '16:9, or #f (= default)
  (define/provide-struct just-a-comment (content)) ; content is list of strings and picts
  (define/provide-struct sinset (l t r b))
  (define/provide-struct click-region (left top right bottom thunk show-click?))
  (define/provide-struct interact (left top right bottom proc)
    ;; transparent for hashing:
    #:transparent)

  (define zero-inset (make-sinset 0 0 0 0))

  (define (check-aspect who v)
    (unless (aspect? v)
      (raise-argument-error who "aspect?" v)))

  (define-unit core@
      (import config^ (prefix viewer: viewer^))
      (export (rename core^ 
                      (local:condense? condense?)
                      (local:printing? printing?)))

      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;                    Setup                      ;;
      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (define local:condense? condense?)
      (define local:printing? printing?)

      (define font-size base-font-size)
      (define gap-size (* 3/4 font-size))
      (define current-gap-size (make-parameter gap-size))
      (define line-sep 2)
      (define title-size (+ font-size 4))
      (define main-font (if (and (not printing?)
				 (string=? (get-family-builtin-face 'default) " Sans"))
			    'default
			    'swiss))
      (define current-main-font (make-parameter main-font))

      (define current-line-sep (make-parameter line-sep))

      (define commentary-content-scale 0.8)

      (let ([use-screen-w (hash-ref use-screen-ws #f)]
            [use-screen-h (hash-ref use-screen-hs #f)]
            [screen-w (hash-ref screen-ws #f)]
            [screen-h (hash-ref screen-hs #f)])
        (when (not (and (= use-screen-w screen-w)
                        (= use-screen-h screen-h)
                        (= pixel-scale 1)
                        (not commentary-on-slide?)))
          (let ([c-scale (if commentary-on-slide?
                             commentary-content-scale
                             1)])
            (current-expected-text-scale (list (* (/ use-screen-w screen-w) pixel-scale c-scale)
                                               (* (/ use-screen-h screen-h) pixel-scale c-scale))))))

      (define red "red")
      (define green "forest green")
      (define blue "blue")
      (define purple "purple")
      (define orange "orange")

      (define current-font-size (make-parameter 
				 font-size
				 (lambda (x)
				   (unless (and (number? x)
						(integer? x)
						(exact? x)
						(positive? x))
				     (raise-argument-error 'current-font-size "exact-nonnegative-integer?" x))
				   x)))
    (define commentary-on-slide-font-size (make-parameter
                                           9
                                           (λ (x)
                                             (unless (exact-positive-integer? x)
                                               (raise-argument-error 'commentary-on-slide-font-size
                                                                     "exact-positive-integer?"
                                                                     x))
                                             x)))

      (define current-title-color (make-parameter
				   green
				   (lambda (x)
				     (unless (or (string? x)
						 (x . is-a? . color%))
				       (raise-argument-error 'current-title-color
                                                             "(or/c string? (is-a?/c color%))"
                                                             x))
				     x)))

      (define (t s) (text s (current-main-font) (current-font-size)))
      (define (it s) (text s `(italic . ,(current-main-font)) (current-font-size)))
      (define (bt s) (text s `(bold . ,(current-main-font)) (current-font-size)))
      (define (bit s) (text s `(bold italic . ,(current-main-font)) (current-font-size)))
      (define (tt s) (text s '(bold . modern) (current-font-size)))
      (define (rt s) (text s 'roman (current-font-size)))

      (define current-titlet
        (make-parameter
         (lambda (s)
           (colorize (text s 
                           `(bold . ,(current-main-font)) 
                           title-size)
                     (current-title-color)))))
          
      (define (titlet s) ((current-titlet) s))

      (define (with-font f k)
	(parameterize ([current-main-font f])
	  (k)))

      (define (tt* . l) (apply vl-append (current-line-sep) (map tt l)))

      (define bullet (if (send (dc-for-text-size) glyph-exists? #\u2022)
			 (t "\u2022")
			 (baseless
			  (cc-superimpose (disk (/ gap-size 2)) 
					  (blank 0 gap-size)))))
      (define o-bullet (baseless
			(cc-superimpose (circle (/ gap-size 2)) 
					(blank 0 gap-size))))


      (define margin 20)
      (define client-ws #hasheq())
      (define client-hs #hasheq())
      (define full-pages #hasheq())
      (define title-h (pict-height (titlet "Hi")))
      (define (mk-titleless-page full-page)
	(inset full-page 0 (- 0 title-h (* 2 gap-size)) 0 0))
      (define titleless-pages #hasheq())
      (define (set-titleless-pages!)
	(set! titleless-pages (for/hasheq ([(aspect full-page) (in-hash full-pages)])
                                (values aspect (mk-titleless-page full-page)))))
      (define (set-margin! m)
	(set! margin m)
	(set! client-ws (for/hasheq ([(aspect w) (in-hash screen-ws)])
                          (values aspect (- w (* margin 2)))))
	(set! client-hs (for/hasheq ([(aspect w) (in-hash screen-hs)])
                          (values aspect (- w (* margin 2)))))
        (set! full-pages (for/hasheq ([(aspect client-w) (in-hash client-ws)])
                           (define client-h (hash-ref client-hs aspect))
                           (values aspect (blank client-w client-h))))
        (set-titleless-pages!))
      (set-margin! margin)

      (define (get-margin) margin)
      (define (get-client-w #:aspect [aspect #f])
        (check-aspect 'get-client-w aspect)
        (hash-ref client-ws aspect))
      (define (get-client-h #:aspect [aspect #f])
        (check-aspect 'get-client-h aspect)
        (hash-ref client-hs aspect))
      (define (get-full-page #:aspect [aspect #f])
        (check-aspect 'get-full-page aspect)
        (hash-ref full-pages aspect))
      (define (get-titleless-page #:aspect [aspect #f])
        (check-aspect 'get-titleless-page aspect)
        (hash-ref titleless-pages aspect))

      (define (set-title-h! h)
	(set! title-h h)
        (set-titleless-pages!))
      (define (get-title-h) title-h)

      (define (set-use-background-frame! on?)
	(viewer:set-use-background-frame! (and on? #t)))

      (define (enable-click-advance! on?)
	(viewer:enable-click-advance! (and on? #t)))

      (define (set-page-numbers-visible! on?)
	(viewer:set-page-numbers-visible! (and on? #t)))

      (define (set-spotlight-style! #:size [size #f] #:color [color #f])
        (viewer:set-spotlight-style! #:size size #:color color))
      
      (define (set-allow-new-slides-after-close! on?)
        (viewer:set-allow-new-slides-after-close! on?))

      (define (pict->pre-render-pict p)
        (viewer:pict->pre-render-pict p))

      (define current-page-number-font 
	(make-parameter
	 (make-object font% 10 'default 'normal 'normal)
	 (lambda (f)
	   (unless (f . is-a? . font%)
	     (raise-argument-error 'current-page-number-font "(is-a?/c font%)" f))
	   f)))
    (define current-page-number-color
      (make-parameter (send the-color-database find-color "black")
                      (lambda (s)
                        (unless (or (s . is-a? . color%)
                                    (string? s))
                          (raise-argument-error 'current-page-number-color
                                                "(or/c string? (is-a?/c color%))" s))
                        (if (string? s)
                            (or (send the-color-database find-color s)
                                (send the-color-database find-color "black"))
                            s))))
      (define current-page-number-adjust (make-parameter 
                                          (λ (n s) s)
                                          (lambda (f)
                                            (unless (procedure-arity-includes? f 2)
                                              (raise-argument-error 'current-page-number-adjust "(procedure-arity-includes/c 2)" f))
                                            f)))
      
      (define page-number 1)

      (define (add-commentary p comment aspect)
	(if commentary-on-slide?
	    (let ([p (scale (frame
			     (inset (let ([tp (launder (hash-ref full-pages aspect))])
				      (refocus (lt-superimpose p tp) tp))
				    margin))
			    commentary-content-scale)]
		  [t (if comment
			 (let ([comments (let loop ([l (just-a-comment-content comment)]
						    [current-line null])
					   (cond
					    [(null? l) (list (reverse current-line))]
					    [(pict? (car l))
					     (loop (cdr l) (cons (car l) current-line))]
					    [else (let ([m (regexp-match #rx"^(.*?)(?:\n|\r\n|\r)[ \t]*(.*)$" (car l))])
						    (if m
							(cons
							 (reverse (cons (cadr m) current-line))
							 (loop (cons (caddr m) (cdr l))
							       null))
							(loop (cdr l) (cons (car l) current-line))))]))])
			   (parameterize ([current-font-size (commentary-on-slide-font-size)])
			     (apply vl-append
				    1
				    (map (lambda (l) 
					   (apply para (- (* (hash-ref screen-ws aspect) (- 1 commentary-content-scale))
							  margin margin 2)
						  l))
					 comments))))
			 (blank))])
	      (ht-append 2 p t))
	    p))

      (define (add-slide! pict title comment page-count inset timeout aspect)
	(viewer:add-talk-slide! 
	 (make-sliderec (make-pict-drawer (add-commentary pict comment aspect))
			title 
			comment
			page-number
			page-count
			inset
			null
                        timeout
                        aspect))
	(set! page-number (+ page-number page-count)))

      (define (skip-slides n)
	(set! page-number (+ page-number n)))

      (define (evenize-width p)
	(let ([w (pict-width p)])
	  ;; Force even size:
	  (inset p 0 0 (+ (- (ceiling w) w)
			  (modulo (ceiling w) 2)) 0)))

      (define (apply-slide-inset sinset pict)
	(inset pict 
	       (- (sinset-l sinset))
	       (- (sinset-t sinset))
	       (- (sinset-r sinset))
	       (- (sinset-b sinset))))

      (define (do-add-slide! content title comment page-count inset timeout aspect)
	(add-slide!
	 (ct-superimpose
	  (apply-slide-inset inset (hash-ref full-pages aspect))
	  content)
	 title
	 comment
	 page-count
	 inset
         timeout
         aspect))

      (define default-slide-assembler
	(lambda (s v-sep p)
	  (apply vc-append v-sep
		 (if s
		     (list (evenize-width (if (pict? s) s (titlet s))) p)
		     (list p)))))

      (define current-slide-assembler
	(make-parameter default-slide-assembler))

      (define-struct name-only (title))
      (define-struct name+title (name title))

      (define (one-slide/title/inset do-add-slide! use-assem? process v-sep skipped-pages s inset timeout aspect a-gap-size . x)
	(let-values ([(x c)
		      (let loop ([x x][c #f][r null])
			(cond
			 [(null? x) (values (reverse r) c)]
			 [(just-a-comment? (car x))
			  (loop (cdr x) (car x) r)]
			 [else
			  (loop (cdr x) c (cons (car x) r))]))])
	  (let ([content ((if use-assem?
			      (current-slide-assembler)
			      default-slide-assembler)
                          (if (name+title? s)
                              (name+title-title s)
                              (and (not (name-only? s)) 
                                   s))
			  v-sep
			  (apply vc-append 
				 a-gap-size
				 (map evenize-width (process x))))])
	    (do-add-slide!
	     content
	     (cond
              [(name-only? s) (name-only-title s)]
              [(name+title? s) (name+title-name s)]
              [else s])
	     c
	     (+ 1 skipped-pages)
	     inset
             timeout
             aspect))))

      (define (slide-error nested string . args)
	(apply error
	       (let loop ([nested nested])
		 (if (null? nested)
		     'slide*
		     (string->symbol (format "~a of ~a" (car nested) (loop (cdr nested))))))
	       string
	       args))

      (define (do-slide/title/tall/inset do-add-slide! use-assem? skip-ok? skip-all? process v-sep s 
                                         inset timeout aspect a-gap-size . x)
	;; Check slides:
	(let loop ([l x][nested null])
	  (or (null? l)
	      (cond
	       [(pict? (car l)) (loop (cdr l) nested)]
	       [(just-a-comment? (car l)) (loop (cdr l) nested)]
	       [(memq (car l) '(next next!)) (and (or (pair? l) 
						      (slide-error nested "argument sequence contains 'next at end"))
						  (loop (cdr l) nested))]
	       [(memq (car l) '(alts alts~)) (and (or (pair? (cdr l))
						      (slide-error nested "argument sequence contains '~a at end" (car l)))
						  (let ([a (cadr l)])
						    (and (or (list? a)
							     (slide-error nested "non-list after '~a: ~e" (car l) a))
							 (andmap (lambda (sl)
								   (unless (list? sl)
								     (slide-error nested "non-list in list after '~a: ~e" 
										  (car l) sl))
								   (loop sl (cons (car l) nested)))
								 a)))
						  (loop (cddr l) nested))]
	       [(eq? (car l) 'nothing) (loop (cdr l) nested)]
	       [else #f])
	      (slide-error nested "argument sequence contains a bad element: ~e" (car l))))

        (skip-slides
         (let loop ([l x][r null][comment #f][skip-all? skip-all?][skipped 0])
           (cond
            [(null? l) 
             (if skip-all?
                 (add1 skipped)
                 (begin
                   (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s 
                          inset timeout aspect a-gap-size (reverse r))
                   0))]
            [(memq (car l) '(nothing))
             (loop (cdr l) r comment skip-all? skipped)]
            [(memq (car l) '(next next!))
             (let ([skip? (or skip-all? (and condense? skip-ok? (eq? (car l) 'next)))])
               (let ([skipped (if skip?
                                  (add1 skipped)
                                  (begin
                                    (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s 
                                           inset timeout aspect a-gap-size (reverse r))
                                    0))])
                 (loop (cdr l) r comment skip-all? skipped)))]
            [(memq (car l) '(alts alts~)) 
             (let ([rest (cddr l)])
               (let aloop ([al (cadr l)][skipped skipped])
                 (cond
                  [(null? al) ;; only happens when al starts out null
                   (loop rest r comment skip-all? skipped)]
                  [(null? (cdr al))
                   (loop (append (car al) rest) r comment skip-all? skipped)]
                  [else
                   (let ([skip? (or skip-all? (and condense? skip-ok? (eq? (car l) 'alts~)))])
                     (let ([skipped (loop (car al) r comment skip? skipped)])
                       (aloop (cdr al) skipped)))])))]
            [else (loop (cdr l) (cons (car l) r) comment skip-all? skipped)]))))

      (define slide/kw 
        (let ([slide (lambda (#:title [s #f]
                              #:name [name s]
                              #:inset [inset zero-inset]
                              #:timeout [timeout #f]
                              #:aspect [aspect #f]
                              #:layout [layout 'auto]
                              #:condense? [condense-this? timeout]
                              #:gap-size [a-gap-size (current-gap-size)]
                              . body)
                       (check-aspect 'slide aspect)
                       (let ([t (if s
                                    (if (equal? name s)
                                        (if (string? s)
                                            (decode s)
                                            s)
                                        (make-name+title name 
                                                         (if (string? s)
                                                             (decode s)
                                                             s)))
                                    (if name
                                        (make-name-only name)
                                        #f))])
                         (case layout
                           [(tall top)
                            (apply do-slide/title/tall/inset 
                                   do-add-slide! #t #t (and condense? condense-this?) values
                                   (if (eq? layout 'tall)
                                       a-gap-size 
                                       (* 2 a-gap-size))
                                   t
                                   inset
                                   timeout
                                   aspect
                                   a-gap-size
                                   body)]
                           [else ; center, auto
                            (apply slide/title/center/inset/timeout/aspect/gap 
                                   (or (not s) (eq? layout 'center))
                                   (and condense? condense-this?)
                                   t
                                   inset 
                                   timeout
                                   aspect
                                   a-gap-size
                                   body)]))
                       (void))])
          slide))

      (define (make-slide-inset l t r b)
	(make-sinset l t r b))

      (define (slide/title/tall/inset/gap v-sep s inset . x)
	(apply do-slide/title/tall/inset do-add-slide! #t #t #f values v-sep s inset #f #f gap-size x))

      (define (slide/title/tall/inset s inset . x)
	(apply slide/title/tall/inset/gap gap-size s inset x))

      (define (slide/name/tall/inset s inset . x)
	(apply slide/title/tall/inset (make-name-only s) inset x))

      (define (slide/title/tall/gap v-sep s timeout . x)
	(apply do-slide/title/tall/inset do-add-slide! #t #t #f values v-sep s zero-inset timeout #f gap-size x))

      (define (slide/title/tall s . x)
	(apply slide/title/tall/gap gap-size s #f x))

      (define (slide/name/tall s . x)
	(apply slide/title/tall (make-name-only s) x))

      (define (slide/title s . x)
	(apply slide/title/tall/gap (* 2 gap-size) s #f x))

      (define (slide/title/timeout s timeout . x)
	(apply slide/title/tall/gap (* 2 gap-size) s timeout x))

      (define (slide/name s . x)
	(apply slide/title (make-name-only s) x))

      (define (slide . x)
	(apply slide/title #f x))

      (define (slide/title/inset s inset . x)
	(apply slide/title/tall/inset/gap (* 2 gap-size) s inset x))

      (define (slide/name/inset s inset . x)
	(apply slide/title/inset (make-name-only s) inset x))

      (define (slide/title/center/inset s inset . x)
        (apply slide/title/center/inset/timeout #t #f s inset #f x))

      (define (slide/title/center/inset/timeout always-center? skip-all? s inset timeout . x)
        (apply slide/title/center/inset/timeout/gap always-center? skip-all? s inset timeout gap-size x))

      (define (slide/title/center/inset/timeout/gap always-center? skip-all? s inset timeout a-gap-size . x)
        (apply slide/title/center/inset/timeout/aspect/gap always-center? skip-all? s inset timeout #f a-gap-size x))
        
      (define (slide/title/center/inset/timeout/aspect/gap always-center? skip-all? s inset timeout aspect a-gap-size . x)
	(let ([max-width 0]
	      [max-height 0]
	      [combine (lambda (x)
			 (apply vc-append a-gap-size
				(map
				 evenize-width
				 x)))])
	  ;; Run through all the slides once to measure (don't actually create slides):
	  (apply do-slide/title/tall/inset
		 (lambda (content title comment page-count inset timeout aspect)
		   (set! max-width (max max-width (pict-width content)))
		   (set! max-height (max max-height (pict-height content))))
		 #f
		 #f
                 #f
		 (lambda (x) (list (combine x)))
		 0 #f inset timeout aspect a-gap-size x)
          (let ([center? (or always-center?
                             (max-height . < . (- (hash-ref client-hs aspect)
                                                  (* 2
                                                     (+ (* 2 a-gap-size)
                                                        title-h)))))])
            (apply do-slide/title/tall/inset
                   do-add-slide!
                   #t
                   #t
                   skip-all?
                   (if center?
                       (lambda (x)
                         (list
                          (cc-superimpose
                           (apply-slide-inset inset (if (and s (not (name-only? s)))
                                                        (hash-ref titleless-pages aspect)
                                                        (hash-ref full-pages aspect)))
                           (ct-superimpose
                            (blank max-width max-height)
                            (combine x)))))
                       values)
                   (if center? 0 (* 2 a-gap-size))
                   s inset timeout aspect a-gap-size x))))

      (define (slide/name/center/inset s inset . x)
	(apply slide/title/center/inset (make-name-only s) inset x))

      (define (slide/title/center s . x)
	(apply slide/title/center/inset s zero-inset x))

      (define (slide/name/center s . x)
	(apply slide/title/center (make-name-only s) x))

      (define (slide/timeout timeout . x) (apply slide/title/timeout #f timeout x))
      (define (slide/inset inset . x) (apply slide/title/inset #f inset x))

      (define (slide/center . x) (apply slide/title/center #f x))
      (define (slide/center/inset inset . x) (apply slide/title/center/inset #f inset x))

      (define (slide/center/timeout t . x)
        (apply slide/title/center/inset/timeout #t #f #f zero-inset t x))

      (define (slide/title/center/timeout s t . x)
        (apply slide/title/center/inset/timeout #t #f s zero-inset t x))

      (define most-recent-slide
	(case-lambda
	 [() (most-recent-slide 0)]
	 [(n) (viewer:most-recent-talk-slide)]))

      (define retract-most-recent-slide
	(lambda ()
	  (let ([slide (viewer:most-recent-talk-slide)])
	    (when slide
	      (set! page-number (sliderec-page slide))
	      (viewer:retract-talk-slide!)
	      slide))))
      
      (define re-slide
	(lambda (s [addition #f])
	  (unless (sliderec? s)
	    (raise-argument-error 're-slide "slide?" s))
	  (viewer:add-talk-slide!
	   (make-sliderec
	    (let ([orig (sliderec-drawer s)]
		  [extra (if addition
			     (make-pict-drawer 
			      (add-commentary addition #f (sliderec-aspect s)))
			     void)])
	      (lambda (dc x y)
		(orig dc x y)
		(extra dc x y)))
	    (sliderec-title s)
	    (sliderec-comment s)
	    page-number
	    1
	    (sliderec-inset s)
	    null
            (sliderec-timeout s)
            (sliderec-aspect s)))
	  (set! page-number (+ page-number 1))))
      
      (define (slide->pict s)
        (unless (sliderec? s)
          (raise-argument-error 'slide->pict "slide?" s))
        (let ([orig (sliderec-drawer s)])
          (dc orig (hash-ref client-ws (sliderec-aspect s)) (hash-ref client-hs (sliderec-aspect s)))))

      (define (start-at-recent-slide)
	(viewer:set-init-page! (max 0 (- page-number 2))))

      (define (done-making-slides)
	(viewer:done-making-slides))

      (define (make-outline #:aspect [aspect #f] . l)
        (check-aspect 'make-outline aspect)
	(define ah (arrowhead gap-size 0))
	(define current-item (colorize (hc-append (- (/ gap-size 2)) ah ah) blue))
	(define other-item (rc-superimpose (ghost current-item) (colorize ah "light gray")))
        (define (to-next l)
          (let ([l (cdddr l)])
            (if (and (pair? l) (number? (car l)))
                (cdr l)
                l)))
        (lambda (which)
          (do-slide/title/tall/inset
           do-add-slide! #t #t #f values
           (* 2 gap-size) ;; v-sep
           (make-name-only
            (format "--~a--"
                    (let loop ([l l])
                      (cond
                        [(null? l) "<unknown>"]
                        [(eq? (car l) which)
                         (cadr l)]
                        [else (loop (to-next l))]))))
           zero-inset
           #f ;; timeout
           aspect
           gap-size
           (blank (+ title-h gap-size))
           (lc-superimpose
            (blank ((hash-ref current-para-widths aspect)) 0)
            (let loop ([l l])
              (cond
                [(null? l) (blank)]
                [else
                 (let ([current? (or (eq? which (car l)) 
                                     (and (list? (car l))
                                          (memq which (car l))))])
                   (vc-append
                    gap-size
                    (para
                     ((hash-ref current-para-widths aspect))
                     (hbl-append
                      (quotient gap-size 2)
                      (if current?
                          current-item
                          other-item)
                      (let ([p (cadr l)])
                        (if (pict? p)
                            p
                            (bt p)))))
                    (let* ([rest (let ([p (loop (to-next l))]
                                       [l (cdddr l)])
                                   (if (and (pair? l) (number? (car l)))
                                       (inset p 0 (car l) 0 0)
                                       p))]
                           [sub-items (caddr l)])
                      (if (and current?
                               sub-items
                               (not (null? sub-items)))
                          (vc-append
                           gap-size
                           (sub-items which)
                           rest)
                          rest))))]))))
          (void)))

      (define (comment . s) 
	(make-just-a-comment s))

      ;; ----------------------------------------

      ;; Move separators (that shouldn't be preceded by extra space)
      ;; at the front of a string to the end of the previous item
      (define (shift-no-sep l)
	(let loop ([l 
		    ;; Flatten l, first:
		    (let loop ([l l])
		      (cond
		       [(null? l) null]
		       [(pair? (car l)) (append (loop (car l)) (loop (cdr l)))]
		       [else (cons (car l) (loop (cdr l)))]))]
		   [a null])
	  ;; Combine strings:
	  (cond
	   [(null? l) (reverse a)]
	   [(null? a) (loop (cdr l) (list (car l)))]
	   [(and (string? (car l)) 
		 (regexp-match #rx"^[-',. :;?!)\U201D\U2019]" (car l)))
	    (let ([m (regexp-match #rx"^([^ ]*) (.*)$" (car l))])
	      (if m
                  (if (string? (car a))
		      (loop (cdr l)
			    (list* (caddr m)
				   (string-append (car a) (cadr m))
				   (cdr a)))
		      (loop (cdr l)
			    (list* (caddr m)
				   (hbl-append (car a) (t (cadr m)))
				   (cdr a))))
		  (if (string? (car a))
		      (loop (cdr l)
			    (cons (string-append (car a) (car l))
				  (cdr a)))
		      (loop (cdr l)
			    (cons (hbl-append (car a) (t (car l)))
				  (cdr a))))))]
	   [else (loop (cdr l) (cons (car l) a))])))

      (define current-para-widths
        (for/hasheq ([(aspect client-w) (in-hash client-ws)])
          (values aspect (make-parameter client-w))))

      (define (get-current-para-width #:aspect [aspect #f])
        (check-aspect 'get-current-para-width aspect)
        (hash-ref current-para-widths aspect))

      (define para/kw
        (let ([para (lambda (#:aspect [aspect #f]
                             #:width [width ((hash-ref current-para-widths aspect))]
                             #:align [align 'left]
                             #:fill? [fill? #t]
                             #:decode? [decode? #t]
                             . s)
                      (check-aspect 'para aspect)
                      (let ([p (para*/align (case align
                                              [(right) vr-append]
                                              [(center) vc-append]
                                              [else vl-append])
                                            width
                                            (if decode?
                                                (decode s)
                                                s))])
                        (if fill?
                            ((case align
                               [(right) rtl-superimpose]
                               [(center) ctl-superimpose]
                               [else ltl-superimpose])
                             (blank width 0)
                             p)
                            p)))])
          para))

      (define (decode s)
        (let loop ([s s])
          (cond
           [(list? s) 
            (map 
             decode
             ;; Remove "\n", and also cancel extra spaces after "\n":
             (let loop ([s s])
               (cond
                [(null? s) null]
                [(equal? (car s) "\n")
                 (let nloop ([s (cdr s)])
                   (if (and (pair? s)
                            (string? (car s)))
                       (let ([a (regexp-replace #rx"^ +" (car s) "")])
                         (if (string=? a "")
                             (nloop (cdr s))
                             (loop (cons a (cdr s)))))
                       (loop s)))]
                [else (cons (car s) (loop (cdr s)))])))]
           [(not (string? s)) s]
           [(regexp-match-positions #rx"---" s)
            => (lambda (m)
                 (string-append (loop (substring s 0 (caar m)))
                                "\u2014"
                                (loop (substring s (cdar m)))))]
           [(regexp-match-positions #rx"--" s)
            => (lambda (m)
                 (string-append (loop (substring s 0 (caar m)))
                                "\u2013"
                                (loop (substring s (cdar m)))))]
           [(regexp-match-positions #px"``" s)
            => (lambda (m)
                 (string-append (loop (substring s 0 (caar m)))
                                "\u201C"
                                (loop (substring s (cdar m)))))]
           [(regexp-match-positions #px"''" s)
            => (lambda (m)
                 (string-append (loop (substring s 0 (caar m)))
                                "\u201D"
                                (loop (substring s (cdar m)))))]
           [(regexp-match-positions #rx"'" s)
            => (lambda (m)
                 (string-append (loop (substring s 0 (caar m)))
                                "\u2019"
                                (loop (substring s (cdar m)))))]           
           [else s])))

      (define (para*/align v-append w . s)
	(define space (t " "))
	(let loop ([pre #f][s (shift-no-sep s)][rest null])
	  (cond
	   [(null? s)
	    (if (null? rest)
		(or pre (blank))
		(loop pre (car rest) (cdr rest)))]
	   [(list? s) (loop pre (car s) (append (cdr s) rest))]
	   [else
	    (let* ([p (if (string? s) (t s) s)])
	      (cond
	       [(< (+ (if pre (pict-width pre) 0)
		      (if pre (pict-width space) 0)
		      (pict-width p)) 
		   w)
		;; small enough
		(loop (if pre 
			  (hbl-append pre space p) 
			  p)
		      rest null)]
	       [(and (string? s) (regexp-match "(.*) (.*)" s))
		;; can break on string
		=> (lambda (m)
		     (loop pre
			   (cadr m) 
			   (cons
			    (caddr m)
			    rest)))]
	       [(not pre)
		(if (null? rest)
		    p
		    (v-append
		     (current-line-sep)
		     p
		     (loop #f rest null)))]
	       [else
		(v-append
		 (current-line-sep)
		 pre
		 (loop p rest null))]))])))

      (define (para* w . s)
	(para*/align vl-append w s))

      (define (para*/r w . s)
	(para*/align vr-append w s))

      (define (para*/c w . s)
	(para*/align vc-append w s))


      (define (para/align superimpose v-append w . s)
	(superimpose (para*/align v-append w s)
		     (blank w 0)))

      (define (para w . s)
	(para/align lbl-superimpose vl-append w s))

      (define (para/r w . s)
	(para/align rbl-superimpose vr-append w s))

      (define (para/c w . s)
	(para/align cbl-superimpose vc-append w s))


      (define (page-para*/align v-append . s)
	(para*/align v-append ((hash-ref current-para-widths #f)) s))

      (define (page-para* . s)
	(page-para*/align vl-append s))

      (define (page-para*/r . s)
	(page-para*/align vr-append s))

      (define (page-para*/c . s)
	(page-para*/align vc-append s))


      (define (page-para/align superimpose v-append . s)
	(para/align superimpose v-append ((hash-ref current-para-widths #f)) s))

      (define (page-para . s)
	(page-para/align lbl-superimpose vl-append s))

      (define (page-para/r . s)
	(page-para/align rbl-superimpose vr-append s))

      (define (page-para/c . s)
	(page-para/align cbl-superimpose vc-append s))

      ;; ----------------------------------------

      (define (l-combiner para w l)
	(apply
	 vl-append
	 gap-size
	 (map (lambda (x) (para w x)) l)))

      ;; ----------------------------------------

      (define item/kw
        (let ([item (lambda (#:gap-size [a-gap-size (current-gap-size)]
                             #:bullet [bullet (if (eq? a-gap-size gap-size)
                                                  bullet
                                                  (scale bullet (/ a-gap-size gap-size)))]
                             #:aspect [aspect #f]
                             #:width [width ((hash-ref current-para-widths aspect))]
                             #:align [align 'left]
                             #:fill? [fill? #t]
                             #:decode? [decode? #t]
                             . s)
                      (check-aspect 'item aspect)
                      (htl-append (/ a-gap-size 2)
                                  bullet 
                                  (para/kw #:aspect aspect
                                           #:width (- width
                                                      (pict-width bullet) 
                                                      (/ a-gap-size 2)) 
                                           #:align align
                                           #:fill? fill?
                                           #:decode? decode?
                                           s)))])
          item))

      (define (item*/bullet bullet w . s)
	(htl-append (/ gap-size 2)
		    bullet 
		    (para* (- w
			      (pict-width bullet) 
			      (/ gap-size 2)) 
			   s)))

      (define (item* w . s)
	(apply item*/bullet bullet w s))

      (define (item w . s)
	(lbl-superimpose (item* w s)
			 (blank w 0)))

      (define (item/bullet b w . s)
	(lbl-superimpose (item*/bullet b w s)
			 (blank w 0)))

      (define (page-item* . s)
	(item* ((hash-ref current-para-widths #f)) s))

      (define (page-item . s)
	(item ((hash-ref current-para-widths #f)) s))

      (define (page-item*/bullet b . s)
	(item*/bullet b ((hash-ref current-para-widths #f)) s))

      (define (page-item/bullet b . s)
	(item/bullet b ((hash-ref current-para-widths #f)) s))

      ;; ----------------------------------------

      (define subitem/kw
        (let ([subitem (lambda (#:gap-size [a-gap-size (current-gap-size)]
                                #:bullet [bullet (if (eq? gap-size a-gap-size)
                                                     o-bullet
                                                     (scale o-bullet (/ a-gap-size gap-size)))]
                                #:aspect [aspect #f]
                                #:width [width ((hash-ref current-para-widths aspect))]
                                #:align [align 'left]
                                #:fill? [fill? #t]
                                #:decode? [decode? #t]
                                . s)
                         (check-aspect 'subitem aspect)
                         (inset (htl-append (/ a-gap-size 2)
                                            bullet 
                                            (para/kw #:aspect aspect
                                                     #:width (- width
                                                                (* 2 a-gap-size)
                                                                (pict-width bullet) 
                                                                (/ a-gap-size 2)) 
                                                     #:align align
                                                     #:fill? fill?
                                                     #:decode? decode?
                                                     s))
                                (* 2 a-gap-size) 0 0 0))])
          subitem))

      (define (subitem* w . s)
	(inset (htl-append (/ gap-size 2)
			   o-bullet 
			   (para* (- w
				     (* 2 gap-size)
				     (pict-width bullet) 
				     (/ gap-size 2)) 
				  s))
	       (* 2 gap-size) 0 0 0))

      (define (subitem w . s)
	(lbl-superimpose (subitem* w s)
			 (blank w 0)))

      (define (page-subitem* . s)
	(subitem* ((hash-ref current-para-widths #f)) s))

      (define (page-subitem . s)
	(subitem ((hash-ref current-para-widths #f)) s))

      ;; ----------------------------------------

      (define (paras* w . l)
	(l-combiner para* w l))

      (define (paras w . l)
	(l-combiner para w l))

      (define (page-paras* . l)
	(l-combiner (lambda (x y) (page-para* y)) ((hash-ref current-para-widths #f)) l))

      (define (page-paras . l)
	(l-combiner (lambda (x y) (page-para y)) ((hash-ref current-para-widths #f)) l))

      ;; ----------------------------------------

      (define (itemize w . l)
	(l-combiner item w l))

      (define (itemize* w . l)
	(l-combiner item* w l))

      (define (page-itemize . l)
	(l-combiner (lambda (x y) (page-item y)) ((hash-ref current-para-widths #f)) l))

      (define (page-itemize* . l)
	(l-combiner (lambda (x y) (page-item* y)) ((hash-ref current-para-widths #f)) l))

      ;; ----------------------------------------

      (define (size-in-pixels p #:aspect [aspect #f])
        (check-aspect 'size-in-pixels aspect)
        (let ([use-screen-w (hash-ref use-screen-ws aspect)]
              [use-screen-h (hash-ref use-screen-hs aspect)]
              [screen-w (hash-ref screen-ws aspect)]
              [screen-h (hash-ref screen-hs aspect)])
          (if (not (and (= use-screen-w screen-w)
                        (= use-screen-h screen-h)))
              (scale p 
                     (/ screen-w use-screen-w)
                     (/ screen-h use-screen-h))
              p)))

      ;; ----------------------------------------
      
      (define (transform-rectangle dc x y w h)
        (define mx (send dc get-initial-matrix))
        (define-values (sx sy) (send dc get-scale))
        (define-values (dx dy) (send dc get-origin))
        (define r (send dc get-rotation))
        (define p (new dc-path%))
        (send p rectangle x y w h)
        (send p rotate r)
        (send p scale sx sy)
        (send p translate dx dy)
        (send p transform mx)
        (send p get-bounding-box))

      (define clickback
	(lambda (pict thunk [show-click? #t])
	  (let ([w (pict-width pict)]
		[h (pict-height pict)])
	    (cons-picture*
	     pict
	     `((place 
		0 0
		,(dc (lambda (dc x y)
                       (define-values (bx by bw bh) (transform-rectangle dc x y w h))
                       (viewer:add-click-region!
                        (make-click-region bx by (+ bx bw) (+ by bh)
                                           thunk
                                           show-click?)))
		     w h
		     (pict-ascent pict)
		     (pict-descent pict))))))))

      (define interactive
	(lambda (pict window-proc)
	  (let ([w (pict-width pict)]
		[h (pict-height pict)])
	    (cons-picture*
	     pict
	     `((place 
		0 0
		,(dc (lambda (dc x y)
                       (define-values (bx by bw bh) (transform-rectangle dc x y w h))
                       (viewer:add-interactive!
                        (make-interact bx by (+ bx bw) (+ by bh)
                                       window-proc)))
		     w h
		     (pict-ascent pict)
		     (pict-descent pict))))))))

      ;; ----------------------------------------

      (define (add-transition! who trans)
	(let ([slide (viewer:most-recent-talk-slide)])
	  (when slide
	    (set-sliderec-transitions! slide 
				       (append (sliderec-transitions slide)
						(list trans))))))
      
      (define scroll-bm #f)
      (define scroll-dc (make-object bitmap-dc%))

      (define scroll-transition
	(lambda (x y w h dx dy [duration 0.20] [steps 12] #:aspect [aspect #f])
          (let ([use-screen-w (hash-ref use-screen-ws aspect)]
                [use-screen-h (hash-ref use-screen-hs aspect)]
                [screen-w (hash-ref screen-ws aspect)]
                [screen-h (hash-ref screen-hs aspect)])
            (add-transition! 'scroll-transition
                             (lambda (offscreen-dc)
                               (let* ([steps-done 0]
                                      [xs (/ use-screen-w screen-w)]
                                      [ys (/ use-screen-h screen-h)]
                                      [bcw (send (send offscreen-dc get-bitmap) get-width)]
                                      [bch (send (send offscreen-dc get-bitmap) get-height)]
                                      [mx (- margin (/ (- use-screen-w bcw) 2 xs))]
                                      [my (- margin (/ (- use-screen-h bch) 2 ys))]
                                      [x-space (ceiling (* xs (/ (abs dx) steps)))]
                                      [y-space (ceiling (* ys (/ (abs dy) steps)))]
                                      [x-in (if (positive? dx)
                                                x-space
                                                0)]
                                      [y-in (if (positive? dy)
                                                y-space
                                                0)])
                                 (unless (and scroll-bm
                                              (>= (send scroll-bm get-width) 
                                                  (+ x-space (* xs w)))
                                              (>= (send scroll-bm get-height) 
                                                  (+ y-space (* ys h))))
                                   (set! scroll-bm (make-bitmap
                                                    (inexact->exact (ceiling (+ x-space (* xs w))))
                                                    (inexact->exact (ceiling (+ y-space (* ys h))))))
                                   (if (send scroll-bm ok?)
                                       (send scroll-dc set-bitmap scroll-bm)
                                       (set! scroll-bm #f)))

                                 (when scroll-bm
                                   (send scroll-dc clear)
                                   (send scroll-dc draw-bitmap-section (send offscreen-dc get-bitmap)
                                         x-in y-in
                                         (* (+ x mx) xs) (* (+ y my) ys)
                                         (* w xs) (* h ys)))
                                 
                                 (lambda (canvas offscreen-dc)
                                   (if (or (not scroll-bm) (= steps-done steps))
                                       'done
                                       (let*-values ([(cw ch) (send canvas get-client-size)])
                                         (let ([xm (- margin (/ (- use-screen-w bcw) 2 xs))]
                                               [ym (- margin (/ (- use-screen-h bch) 2 ys))])
                                           (set! steps-done (add1 steps-done))
                                           (let ([draw
                                                  (lambda (dc xm ym)
                                                    (send dc draw-bitmap-section
                                                          scroll-bm
                                                          (- (* (+ x xm (* dx (/ steps-done steps))) xs) x-in)
                                                          (- (* (+ y ym (* dy (/ steps-done steps))) ys) y-in)
                                                          0 0 
                                                          (ceiling (* xs (+ w (/ (abs dx) steps))))
                                                          (ceiling (* ys (+ h (/ (abs dy) steps))))))])
                                             (draw (send canvas get-dc) xm ym)
                                             (draw offscreen-dc mx my)))
                                         (/ duration steps))))))))))

      (define pause-transition
	(lambda (time)
	  (add-transition! 'pause-transition
			   (lambda (offscreen-dc)
			     (let ([done? #f])
			       (lambda (canvas offscreen-dc)
				 (if done?
				     'done
				     (begin
				       (set! done? #t)
				       time))))))))))
