figure.rkt (7462B)
1 #lang scheme/base 2 (require racket/contract/base 3 scribble/manual 4 scribble/core 5 scribble/decode 6 scribble/html-properties 7 scribble/latex-properties 8 setup/main-collects 9 "private/counter.rkt" 10 scribble/private/lang-parameters) 11 12 (provide figure 13 figure* 14 figure** 15 figure-here 16 (contract-out 17 [Figure-target (->* (string?) 18 (#:continue? any/c) 19 element?)] 20 [Figure-ref (->* (string?) 21 (#:link-render-style link-render-style?) 22 #:rest (listof string?) 23 element?)] 24 [figure-ref (->* (string?) 25 (#:link-render-style link-render-style?) 26 #:rest (listof string?) 27 element?)]) 28 left-figure-style 29 center-figure-style 30 right-figure-style 31 suppress-floats 32 (rename-out [left-figure-style left])) 33 34 (define figure-style-extras 35 (let ([abs (lambda (s) 36 (path->main-collects-relative 37 (collection-file-path s "scriblib")))]) 38 (list 'never-indents 39 (make-css-addition (abs "figure.css")) 40 (make-tex-addition (abs "figure.tex"))))) 41 42 ;; outer layer: 43 (define herefigure-style (make-style "Herefigure" figure-style-extras)) 44 (define figure-style (make-style "Figure" figure-style-extras)) 45 (define figuremulti-style (make-style "FigureMulti" figure-style-extras)) 46 (define figuremultiwide-style (make-style "FigureMultiWide" figure-style-extras)) 47 48 ;; middle layer: 49 (define center-figure-style (make-style "Centerfigure" figure-style-extras)) 50 (define left-figure-style (make-style "Leftfigure" figure-style-extras)) 51 (define right-figure-style (make-style "Rightfigure" figure-style-extras)) 52 53 ;; inner layer: 54 (define figureinside-style (make-style "FigureInside" figure-style-extras)) 55 56 (define legend-style (make-style "Legend" figure-style-extras)) 57 (define legend-continued-style (make-style "LegendContinued" figure-style-extras)) 58 59 (define centertext-style (make-style "Centertext" figure-style-extras)) 60 61 ;; See "figure.js": 62 (define figure-target-style 63 (make-style #f 64 (list 65 (make-attributes '((x-target-lift . "Figure"))) 66 (make-js-addition 67 (path->main-collects-relative 68 (collection-file-path "figure.js" "scriblib")))))) 69 70 (define (make-figure-ref c s) 71 (element (style "FigureRef" (list* (command-extras (list s)) 72 figure-style-extras)) 73 c)) 74 (define (make-figure-target c s) 75 (element (style "FigureTarget" (cons (command-extras (list s)) 76 figure-style-extras)) 77 c)) 78 79 (define (figure tag caption 80 #:style [style center-figure-style] 81 #:label-sep [label-sep (default-figure-label-sep)] 82 #:label-style [label-style #f] 83 #:continue? [continue? #f] 84 . content) 85 (figure-helper figure-style style label-sep label-style tag caption content continue?)) 86 87 (define (figure-here tag caption 88 #:style [style center-figure-style] 89 #:label-sep [label-sep (default-figure-label-sep)] 90 #:label-style [label-style #f] 91 #:continue? [continue? #f] 92 . content) 93 (figure-helper herefigure-style style label-sep label-style tag caption content continue?)) 94 95 (define (figure* tag caption 96 #:style [style center-figure-style] 97 #:label-sep [label-sep (default-figure-label-sep)] 98 #:label-style [label-style #f] 99 #:continue? [continue? #f] 100 . content) 101 (figure-helper figuremulti-style style label-sep label-style tag caption content continue?)) 102 (define (figure** tag caption 103 #:style [style center-figure-style] 104 #:label-sep [label-sep (default-figure-label-sep)] 105 #:label-style [label-style #f] 106 #:continue? [continue? #f] 107 . content) 108 (figure-helper figuremultiwide-style style label-sep label-style tag caption content continue?)) 109 110 (define (figure-helper figure-style content-style label-sep label-style tag caption content continue?) 111 (make-nested-flow 112 figure-style 113 (list 114 (make-nested-flow 115 content-style 116 (list (make-nested-flow figureinside-style (decode-flow content)))) 117 (make-paragraph 118 centertext-style 119 (list (make-element (if continue? 120 legend-continued-style 121 legend-style) 122 (list (Figure-target tag 123 #:label-sep label-sep 124 #:label-style label-style 125 #:continue? continue?) 126 (make-element (default-figure-caption-style) caption)))))))) 127 128 (define figures (new-counter "figure" 129 #:target-wrap make-figure-target 130 #:ref-wrap make-figure-ref)) 131 (define (Figure-target tag 132 #:continue? [continue? #f] 133 #:label-sep [label-sep ": "] 134 #:label-style [label-style #f]) 135 (counter-target figures tag 136 (default-figure-label-text) 137 #:label-suffix (list (if continue? " (continued)" "") label-sep) 138 #:label-style label-style 139 #:target-style figure-target-style 140 #:continue? continue?)) 141 142 (define (ref-proc initial) 143 (lambda (tag #:link-render-style [link-style #f] 144 . tags) 145 (cond 146 [(null? tags) 147 (make-element 148 #f 149 (counter-ref figures tag (string-append initial "igure") 150 #:link-render-style link-style))] 151 [(null? (cdr tags)) 152 (define tag1 tag) 153 (define tag2 (car tags)) 154 (make-element #f (list (counter-ref figures tag1 (string-append initial "igures") 155 #:link-render-style link-style) 156 " and " 157 (counter-ref figures tag2 #f 158 #:link-render-style link-style)))] 159 [else 160 (make-element #f (cons (counter-ref figures tag (string-append initial "igures") 161 #:link-render-style link-style) 162 (let loop ([tags tags]) 163 (cond 164 [(null? (cdr tags)) 165 (list ", and " 166 (counter-ref figures (car tags) #f 167 #:link-render-style link-style))] 168 [else 169 (list* ", " 170 (counter-ref figures (car tags) #f 171 #:link-render-style link-style) 172 (loop (cdr tags)))]))))]))) 173 174 (define Figure-ref (ref-proc "F")) 175 (define figure-ref (ref-proc "f")) 176 177 (define (suppress-floats) 178 (make-element "suppressfloats" null))