scribble-enhanced/scribble-lib/scriblib/figure.rkt

#lang scheme/base

(require scribble/manual
         scribble/core
         scribble/decode
         scribble/html-properties
         scribble/latex-properties
         setup/main-collects
         "private/counter.rkt")

(provide figure
         figure*
         figure**
         figure-here
         Figure-target 
         Figure-ref
         figure-ref
         left-figure-style
         center-figure-style
         right-figure-style
         suppress-floats
         (rename-out [left-figure-style left]))

(define figure-style-extras
  (let ([abs (lambda (s)
               (path->main-collects-relative
                (collection-file-path s "scriblib")))])
    (list 'never-indents
          (make-css-addition (abs "figure.css"))
          (make-tex-addition (abs "figure.tex")))))

;; outer layer:
(define herefigure-style  (make-style "Herefigure" figure-style-extras))
(define figure-style (make-style "Figure" figure-style-extras))
(define figuremulti-style (make-style "FigureMulti" figure-style-extras))
(define figuremultiwide-style (make-style "FigureMultiWide" figure-style-extras))

;; middle layer:
(define center-figure-style (make-style "Centerfigure" figure-style-extras))
(define left-figure-style (make-style "Leftfigure" figure-style-extras))
(define right-figure-style (make-style "Rightfigure" figure-style-extras))

;; inner layer:
(define figureinside-style (make-style "FigureInside" figure-style-extras))

(define legend-style (make-style "Legend" figure-style-extras))
(define legend-continued-style (make-style "LegendContinued" figure-style-extras))

(define centertext-style (make-style "Centertext" figure-style-extras))

;; See "figure.js":
(define figure-target-style
  (make-style #f
              (list
               (make-attributes '((x-target-lift . "Figure")))
               (make-js-addition
                (path->main-collects-relative
                 (collection-file-path "figure.js" "scriblib"))))))

(define (make-figure-ref c s)
  (element (style "FigureRef" (list* (command-extras (list s))
                                     figure-style-extras))
    c))
(define (make-figure-target c s)
  (element (style "FigureTarget" (cons (command-extras (list s))
                                       figure-style-extras))
    c))

(define (figure tag caption 
                #:style [style center-figure-style]
                #:continue? [continue? #f]
                . content)
  (figure-helper figure-style style tag caption content continue?))

(define (figure-here tag caption 
                     #:style [style center-figure-style] 
                     #:continue? [continue? #f]
                     . content)
  (figure-helper herefigure-style style tag caption content continue?))

(define (figure* tag caption 
                 #:style [style center-figure-style]
                 #:continue? [continue? #f]
                 . content)
  (figure-helper figuremulti-style style tag caption content continue?))
(define (figure** tag caption 
                  #:style [style center-figure-style] 
                  #:continue? [continue? #f]
                  . content)
  (figure-helper figuremultiwide-style style tag caption content continue?))

(define (figure-helper figure-style content-style tag caption content continue?)
  (make-nested-flow 
   figure-style 
   (list
    (make-nested-flow
     content-style
     (list (make-nested-flow figureinside-style (decode-flow content))))
    (make-paragraph
     centertext-style
     (list (make-element (if continue?
                             legend-continued-style
                             legend-style)
                         (list (Figure-target tag #:continue? continue?) caption)))))))

(define figures (new-counter "figure" 
                             #:target-wrap make-figure-target
                             #:ref-wrap make-figure-ref))
(define (Figure-target tag #:continue? [continue? #f])
  (counter-target figures tag 
                  "Figure" 
                  (if continue? " (continued): " ": ")
                  #:target-style figure-target-style
                  #:continue? continue?))

(define (ref-proc initial)
  (case-lambda 
   [(tag)
    (make-element #f (list (counter-ref figures tag (string-append initial "igure"))))]
   [(tag1 tag2)
    (make-element #f (list (counter-ref figures tag1 (string-append initial "igures"))
                           " and "
                           (counter-ref figures tag2 #f)))]
   [(tag . tags)
    (make-element #f (cons (counter-ref figures tag (string-append initial "igures"))
                           (let loop ([tags tags])
                             (cond
                              [(null? (cdr tags))
                               (list ", and "
                                     (counter-ref figures (car tags) #f))]
                              [else
                               (list* ", "
                                      (counter-ref figures (car tags) #f)
                                      (loop (cdr tags)))]))))]))

(define Figure-ref (ref-proc "F"))
(define figure-ref (ref-proc "f"))

(define (suppress-floats)
  (make-element "suppressfloats" null))