add make-numberer to generalize section numbering

scribble-doc/scribblings/scribble/core.scrbl

@@ -396,10 +396,19 @@ The recognized @tech{style properties} are as follows:
        @racket['hidden] (for consistency in non-Latex output).}
 
  @item{@racket['grouper] --- The part is numbered with a Roman
-       numeral, and its subsections continue numbering as if they
+       numeral, by default, and its subsections continue numbering as
-       appeared in the preceeding part. In other words, the part acts
+       if they appeared in the preceeding part. In other words, the
-       like a ``part'' in a book where chapter numbering is continuous
+       part acts like a ``part'' in a book where chapter numbering is
-       across parts.}
+       continuous across parts.}
+
+ @item{@tech{numberer} --- A @tech{numberer} created with
+       @racket[make-numberer] determines a representation of the
+       part's section number as an extension of it's patent's number.
+       A @tech{numberer} overrides the default representation, which
+       is a natural number or (in the case of an accompanying
+       @racket['grouper] property) a Roman numeral. If a
+       @racket['unnumbered] property is also present, a
+       @tech{numberer} property is ignored.}
 
  @item{@racket['toc] --- Sub-parts of the part are rendered on separate
        pages for multi-page HTML mode.}
@@ -1076,18 +1085,42 @@ If a @racket[render-element] instance is serialized (such as when
 saving collected info), it is reduced to a @racket[element] instance.}
 
 
-@defstruct[collected-info ([number (listof (or/c #f exact-nonnegative-integer? string?))]
+@defstruct[collected-info ([number (listof part-number-item?)]
                            [parent (or/c #f part?)]
                            [info any/c])]{
 
 Computed for each part by the @techlink{collect pass}.
 
 The length of the @racket[number] list indicates the section's nesting
-depth.  Numbers in @racket[number] correspond to the section's number,
+depth. Elements of @racket[number] correspond to the section's number,
-it's parent's number, etc. A non-empty string is used for a
+it's parent's number, and so on (that is, the section numbers are in
-@racket['grouper] section. For an unnumbered section, @racket[#f] is
+reverse order):
-used in place of all numbers and @racket[""] in place of all non-empty
+
-strings.}
+@itemlist[
+
+ @item{A number value corresponds to a normally numbered
+       section.}
+
+ @item{A non-empty string corresponds to a @racket['grouper] section,
+       which is shown as part of the combined section number only when
+       it's the first element.}
+
+ @item{A a list corresponds to a @tech{numberer}-generated section
+       string plus its separator string, where the separator is used
+       in a combined section number after the section string and
+       before a subsection's number (or, for some output modes, before
+       the title of the section).}
+
+ @item{For an unnumbered section, a @racket[#f] is used in place of
+       any number or lists element, while @racket[""] is used in place
+       of all non-empty strings.}
+
+]}
+
+@history[#:changed "6.4" @elem{Added @racket[(list/c string? string?)]
+                               number items for
+                               @tech{numberer}-generated section
+                               numbers.}]}
 
 
 @defstruct[target-url ([addr path-string?])]{
@@ -1313,6 +1346,61 @@ Returns the width in characters of the given @tech{content}.
 Returns the width in characters of the given @tech{block}.}
 
 
+@defproc[(part-number-item? [v any/c]) boolean]{
+
+Return @racket[#t] if @racket[v] is @racket[#f], an exact non-negative
+integer, a string, or a list containing two strings. See @racket[part]
+for information on how different representations are used for numbering.
+
+@history[#:added "6.4"]}
+
+
+@deftogether[(
+@defproc[(numberer? [v any/c]) boolean?]
+@defproc[(make-numberer [step (any/c (listof part-number-item?)
+                               . -> .
+                               (values part-number-item? any/c))]
+                        [initial-value any/c])
+          numberer?]
+@defproc[(numberer-step [n numberer?]
+                        [parent-number (listof part-number-item?)]
+                        [ci collect-info?]
+                        [numberer-values hash?])
+         (values part-number-item? hash?)]
+)]{
+
+A @deftech{numberer} implements a representation of a section number
+that increment separately from the default numbering style and that
+can be rendered differently than as Arabic numerals.
+
+The @racket[numberer?] function returns @racket[#t] if @racket[v] is a
+@tech{numberer}, or @racket[#f] otherwise.
+
+The @racket[make-numberer] function creates a @tech{numberer}. The
+@racket[step] function computes both the current number's
+representation and increments the number, where the ``number'' can be
+an arbitrary value; the @racket[initial-value] argument determines the
+initial value of the ``number'', and the @racket[step] function
+receives the current value as its first argument and returns an
+incremented value as its second result. A numberer's ``number'' value
+starts fresh at each new nesting level. In addition to the numberer's
+current value, the @racket[step] function receives the parent
+section's numbering (so that its result can depend on the part's
+nesting depth).
+
+The @racket[numberer-step] function is normally used by a renderer. It
+applies a @tech{numberer}, given the parent section's number, a
+@racket[collect-info] value, and a hash table that accumulates
+@tech{numberer} values at a given nesting layer. The
+@racket[collect-info] argument is needed because a @tech{numberer}'s
+identity is based on a @racket[generated-tag]. The result of
+@racket[numberer-step] is the rendered form of the current section
+number plus an updated hash table with an incremented value for the
+@tech{numberer}.
+
+@history[#:added "6.4"]}
+
+
 @defstruct[collect-info ([fp any/c] [ht any/c] [ext-ht any/c] 
                          [ext-demand (tag? collect-info? . -> . any/c)]
                          [parts any/c] 

scribble-lib/scribble/base-render.rkt

@@ -71,7 +71,7 @@
     (define/public (index-manual-newlines?)
       #f)
 
-    (define/public (format-number number sep)
+    (define/public (format-number number sep [keep-separator? #f])
       (if (or (null? number)
               (andmap (lambda (x) (or (not x) (equal? x "")))
                       number)
@@ -81,13 +81,25 @@
           (cons (let ([s (string-append
                           (apply
                            string-append
-                           (map (lambda (n) (if (number? n) (format "~a." n) ""))
+                           (map (lambda (n) 
+                                  (cond
+                                   [(number? n) (format "~a." n)]
+                                   [(or (not n) (string? n)) ""]
+                                   [(pair? n) (string-append (car n) (cadr n))]))
                                 (reverse (cdr number))))
                           (if (and (car number) 
                                    (not (equal? "" (car number))))
-                              (format "~a." (car number)) 
+                              (if (pair? (car number))
+                                  (if keep-separator?
+                                      (string-append (caar number)
+                                                     (cadar number))
+                                      (caar number))
+                                  (format "~a." (car number)))
                               ""))])
-                  (substring s 0 (sub1 (string-length s))))
+                  (if (or keep-separator?
+                          (pair? (car number)))
+                      s
+                      (substring s 0 (sub1 (string-length s)))))
                 sep)))
 
     (define/public (number-depth number)
@@ -501,10 +513,10 @@
         ci))
 
     (define/public (start-collect ds fns ci)
-      (map (lambda (d) (collect-part d #f ci null 1))
+      (for-each (lambda (d) (collect-part d #f ci null 1 #hash()))
-           ds))
+                ds))
 
-    (define/public (collect-part d parent ci number init-sub-number)
+    (define/public (collect-part d parent ci number init-sub-number init-sub-numberers)
       (let ([p-ci (make-collect-info
                    (collect-info-fp ci)
                    (make-hash)
@@ -524,7 +536,7 @@
                                         parent
                                         (collect-info-ht p-ci)))
         (define grouper? (and (pair? number) (part-style? d 'grouper)))
-        (define next-sub-number
+        (define-values (next-sub-number next-sub-numberers)
           (parameterize ([current-tag-prefixes
                           (extend-prefix d (fresh-tag-collect-context? d p-ci))])
             (when (part-title-content d)
@@ -534,37 +546,54 @@
             (collect-flow (part-blocks d) p-ci)
             (let loop ([parts (part-parts d)]
                        [pos init-sub-number]
-                       [sub-pos 1])
+                       [numberers init-sub-numberers]
+                       [sub-pos 1]
+                       [sub-numberers #hash()])
               (if (null? parts)
-                  pos
+                  (values pos numberers)
                   (let ([s (car parts)])
                     (define unnumbered? (part-style? s 'unnumbered))
                     (define hidden-number? (or unnumbered?
                                                (part-style? s 'hidden-number)))
                     (define sub-grouper? (part-style? s 'grouper))
-                    (define next-sub-pos
+                    (define numberer (and (not unnumbered?)
+                                          (for/or ([p (style-properties (part-style s))]
+                                                   #:when (numberer? p))
+                                            p)))
+                    (define-values (numberer-str next-numberers)
+                      (if numberer
+                          (numberer-step numberer number p-ci numberers)
+                          (values #f numberers)))
+                    (define-values (next-sub-pos next-sub-numberers)
                       (collect-part s d p-ci
                                     (cons (if hidden-number?
                                               (if sub-grouper?
                                                   ""
                                                   #f)
-                                              (if sub-grouper?
+                                              (if numberer
-                                                  (number->roman pos)
+                                                  numberer-str
-                                                  pos))
+                                                  (if sub-grouper?
+                                                      (number->roman pos)
+                                                      pos)))
                                           (if hidden-number?
                                               (for/list ([i (in-list number)])
                                                 (if (string? i)
                                                     i
                                                     #f))
                                               number))
-                                    sub-pos))
+                                    sub-pos
+                                    sub-numberers))
                     (loop (cdr parts)
-                          (if unnumbered?
+                          (if (or unnumbered? numberer)
                               pos
                               (add1 pos))
+                          next-numberers
                           (if sub-grouper?
                               next-sub-pos
-                              1)))))))
+                              1)
+                          (if sub-grouper?
+                              next-sub-numberers
+                              #hash())))))))
         (let ([prefix (part-tag-prefix d)])
           (for ([(k v) (collect-info-ht p-ci)])
             (when (cadr k)
@@ -572,7 +601,7 @@
                                    (convert-key prefix k) 
                                    k) 
                             v))))
-        next-sub-number))
+        (values next-sub-number next-sub-numberers)))
 
     (define/private (convert-key prefix k)
       (case (car k)

scribble-lib/scribble/core.rkt

@@ -160,6 +160,57 @@
         (andmap (λ (l) (= l1 (length l)))
                 (cdr ls)))))
 
+;; ----------------------------------------
+
+(define-struct numberer (tag step-proc initial-value)
+  #:constructor-name numberer
+  #:property
+  prop:serializable
+  (make-serialize-info
+   (lambda (d)
+     (vector (numberer-tag d)
+             (numberer-initial-value d)))
+   #'deserialize-numberer
+   #f
+   (or (current-load-relative-directory) (current-directory))))
+
+(provide deserialize-numberer)
+(define deserialize-numberer
+  (make-deserialize-info (lambda (tag init-val)
+                           (numberer tag #f))
+                         (lambda (tag init-val)
+                           (error "cannot allocate numberer for cycle"))))
+
+(define (make-numberer spec-proc initial-value)
+  (numberer (generated-tag) spec-proc initial-value))
+
+(define (numberer-step n parent-numbers ci ht)
+  (define tag (generate-tag `(numberer ,(numberer-tag n)) ci))
+  (define-values (numberer-str new-val)
+    (let ([step (numberer-step-proc n)])
+      (step (hash-ref ht tag (lambda () (numberer-initial-value n)))
+            parent-numbers)))
+  (values numberer-str (hash-set ht tag new-val)))
+
+(define part-number-item?
+  (or/c #f exact-nonnegative-integer? string? (list/c string? string?)))
+
+(provide
+ part-number-item?
+ numberer?
+ (contract-out
+  [make-numberer ((any/c (listof part-number-item?)
+                         . -> . (values part-number-item? any/c))
+                  any/c
+                  . -> . numberer?)]
+  [numberer-step (numberer?
+                  (listof part-number-item?)
+                  collect-info?
+                  hash?
+                  . -> . (values part-number-item? hash?))]))
+
+;; ----------------------------------------
+
 (provide-structs
  [part ([tag-prefix (or/c false/c string?)]
         [tags (listof tag?)]
@@ -211,6 +262,7 @@
  [target-url ([addr path-string?])]
  [color-property ([color (or/c string? (list/c byte? byte? byte?))])]
  [background-color-property ([color (or/c string? (list/c byte? byte? byte?))])]
+ [numberer-property ([numberer numberer?] [argument any/c])]
 
  [table-columns ([styles (listof style?)])]
  [table-cells ([styless (listof (listof style?))])]
@@ -219,7 +271,7 @@
             [center-name string?]
             [bottom-name string?])]
 
- [collected-info ([number (listof (or/c false/c exact-nonnegative-integer? string?))]
+ [collected-info ([number (listof part-number-item?)]
                   [parent (or/c false/c part?)]
                   [info any/c])]
 

scribble-lib/scribble/html-render.rkt

@@ -341,12 +341,12 @@
     ;; ----------------------------------------
 
     (define/override (start-collect ds fns ci)
-      (map (lambda (d fn)
+      (for-each (lambda (d fn)
-             (parameterize ([current-output-file fn]
+                  (parameterize ([current-output-file fn]
-                            [current-top-part d])
+                                 [current-top-part d])
-               (collect-part d #f ci null 1)))
+                    (collect-part d #f ci null 1 #hash())))
-           ds
+                ds
-           fns))
+                fns))
 
     (define/public (part-whole-page? p ri)
       (let ([dest (resolve-get p ri (car (part-tags/nonempty p)))])
@@ -1906,14 +1906,14 @@
 
     (define/override (start-collect ds fns ci)
       (parameterize ([current-part-files (make-hash)])
-        (map (lambda (d fn)
+        (for-each (lambda (d fn)
-               (parameterize ([collecting-sub
+                    (parameterize ([collecting-sub
-                               (if (part-style? d 'non-toc)
+                                    (if (part-style? d 'non-toc)
-                                   1
+                                        1
-                                   0)])
+                                        0)])
-                 (super start-collect (list d) (list fn) ci)))
+                      (super start-collect (list d) (list fn) ci)))
-             ds
+                  ds
-             fns)))
+                  fns)))
 
     (define/private (check-duplicate-filename orig-s)
       (let ([s (string-downcase (path->string orig-s))])
@@ -1922,7 +1922,7 @@
                  orig-s))
         (hash-set! (current-part-files) s #t)))
 
-    (define/override (collect-part d parent ci number sub-init-number)
+    (define/override (collect-part d parent ci number sub-init-number sub-init-numberers)
       (let ([prev-sub (collecting-sub)])
         (parameterize ([collecting-sub (if (part-style? d 'toc)
                                            1 
@@ -1936,8 +1936,8 @@
                 (make-directory* (path-only full-filename))
                 (check-duplicate-filename full-filename)
                 (parameterize ([current-output-file full-filename])
-                  (super collect-part d parent ci number sub-init-number)))
+                  (super collect-part d parent ci number sub-init-number sub-init-numberers)))
-            (super collect-part d parent ci number sub-init-number)))))
+              (super collect-part d parent ci number sub-init-number sub-init-numberers)))))
 
     (define/override (render-top ds fns ri)
       (map (lambda (d fn)

scribble-lib/scribble/markdown-render.rkt

@@ -41,9 +41,9 @@
       (let ([number (collected-info-number (part-collected-info d ht))])
         (unless (part-style? d 'hidden)
           (printf (string-append (make-string (add1 (number-depth number)) #\#) " "))
-          (let ([s (format-number number '())])
+          (let ([s (format-number number '() #t)])
             (unless (null? s)
-              (printf "~a.~a" 
+              (printf "~a~a" 
                       (car s)
                       (if (part-title-content d)
                           " "

scribble-lib/scribble/text-render.rkt

@@ -37,9 +37,9 @@
     (define/override (render-part d ht)
       (let ([number (collected-info-number (part-collected-info d ht))])
         (unless (part-style? d 'hidden)
-          (let ([s (format-number number '())])
+          (let ([s (format-number number '() #t)])
             (unless (null? s)
-              (printf "~a.~a" 
+              (printf "~a~a" 
                       (car s)
                       (if (part-title-content d)
                           " "

scribble-test/tests/scribble/docs/numberer.scrbl

@@ -0,0 +1,37 @@
+#lang scribble/base
+@(require scribble/core)
+
+@(define P (make-numberer (lambda (v parent-number)
+                            (values (list (format "[~a]" v) ; number in brackets
+                                          "")  ; no separator afterward
+                                    (add1 v))) ; increment section number
+                          1)) @; count from 1
+@(define PL (make-numberer (lambda (v parent-number)
+                             (values (list (if (null? parent-number)
+                                               (string v) ; top-level section is uppercase
+                                               (string-downcase (string v))) ; nested is lowercase
+                                           ",")         ;  "," as separator
+                                     (integer->char (add1 (char->integer v))))) ; increment letter
+                           #\A)) @; count from A
+
+@(define (P-section . s)  (section #:style (style #f (list P))  s))
+@(define (PL-section . s) (section #:style (style #f (list PL)) s))
+@(define (PL-subsection . s) (subsection #:style (style #f (list PL)) s))
+
+@title{Two Tracks}
+
+@P-section{Px}
+
+@PL-section{Py}
+
+@PL-section{PLx}
+
+@P-section{Pz}
+@PL-subsection{PL-subx}
+@subsection{Normal}
+@PL-subsection{PL-suby}
+
+@PL-section{PLy}
+
+@PL-section{PLz}
+@subsection{Normal2}

scribble-test/tests/scribble/docs/numberer.txt

@@ -0,0 +1,29 @@
+Two Tracks
+
+[1] Px
+
+
+A, Py
+
+
+B, PLx
+
+
+[2] Pz
+
+[2]a, PL-subx
+
+
+[2]1. Normal
+
+
+[2]b, PL-suby
+
+
+C, PLy
+
+
+D, PLz
+
+D,1. Normal2
+