Changeset 6459 in project


Ignore:
Timestamp:
10/21/07 02:53:45 (13 years ago)
Author:
Kon Lovett
Message:

save

Location:
tabular-list/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • tabular-list/trunk/tabular-list.scm

    r6457 r6459  
    88;; Notes
    99;;
    10 ;; - Use format for justification & fill - headers, labels, & cells.
    11 ;; Per item & per category.
     10;; - Have header, trailer, labels.
    1211;;
    1312;; - Have borders - top/bottom/left/right outside/inside, inner (this is spacing).
     
    2019
    2120(use srfi-1 srfi-13)
    22 (use miscmacros format-modular)
     21(use miscmacros)
    2322
    2423(eval-when (compile)
     
    3837      list-tabular-formatting
    3938      list-tabular-widths
    40       %display-list-tabular
    4139      *display-list-tabular
    4240      display-list-tabular) ) )
     
    10098;;;
    10199
    102 ;;
    103 
    104 (define (%display-list-tabular rows header widths formatting spacing port)
     100;; Returns a procedure ; ((or list vector) -> unspecified)
     101
     102(define (%make-display-tabulator header header-score trailer trailer-score top bottom left right outside inside label label-width widths formatting port)
     103  (let* (
     104      [rowno 0]
     105      [totwd
     106        (apply + (if left (string-length left) 0)
     107                 (if label label-width 0)
     108                 (if outside (* 2 (string-length outside)) 0)
     109                 (* (length widths) (string-length inside))
     110                 (if right (string-length right) 0)
     111                 widths) ]
     112      [dspfil
     113        (lambda (chr cnt)
     114          (when (positive? cnt)
     115            (format port "~A" (make-string cnt chr)) ) ) ]
     116      [dspcel
     117        (lambda (str wid)
     118          (format port "~A" str)
     119          (dspfil #\space (- wid (string-length str))) ) ]
     120      [dsptop
     121        (lambda ()
     122          (when top
     123            (display (top totwd))
     124            (newline) ) ) ]
     125      [dsplft
     126        (lambda ()
     127          (when left
     128            (display left) )
     129          (when outside
     130            (display outside) ) ) ]
     131      [dsprgt
     132        (lambda ()
     133          (when outside
     134            (display outside) )
     135          (when right
     136            (display right) )
     137          (newline) ) ]
     138      [dspbtm
     139        (lambda ()
     140          (when bottom
     141            (display (bottom totwd))
     142            (newline) ) ) ]
     143      [dsplbl
     144        (lambda (rowno)
     145          (when label
     146            (dspcel (label rowno) label-width)
     147            (display inside) ) ) ]
     148      [dsprow
     149        (lambda (rowno row)
     150          (dsplft)
     151          (dsplbl rowno)
     152          (for-each (let ([1st #t])
     153                      (lambda (dat fmt wid)
     154                        (unless 1st
     155                          (set! 1st #f)
     156                          (display inside) )
     157                        (dspcel (format #f fmt dat) wid) ) )
     158                    row formatting widths)
     159          (dsprgt) ) ]
     160      [dspscr
     161        (lambda (chr)
     162          (when chr
     163            (dsplft)
     164            (when label
     165              (dspfil chr label-width)
     166              (display inside) )
     167            (for-each (let ([1st #t])
     168                        (lambda (wid)
     169                          (unless 1st
     170                            (set! 1st #f)
     171                            (display inside) )
     172                          (dspfil chr wid) ) )
     173                      widths)
     174            (dsprgt) ) ) ]
     175      [dsphdr
     176        (lambda ()
     177          (when header
     178            (dsplft)
     179            (when label
     180              (dspfil #\space label-width) )
     181            (for-each dspcel header widths)
     182            (dsprgt)
     183            (dspscr header-score) ) ) ]
     184      [dsptlr
     185        (lambda ()
     186          (unless trailer
     187            (dspscr trailer-score)
     188            (dsplft)
     189            (when label
     190              (dspfil #\space label-width) )
     191            (for-each dspcel trailer widths)
     192            (dsprgt) ) ) ] )
     193    ;
     194    (lambda (row)
     195      (when rowno
     196        (when (zero? rowno)
     197          (dsptop)
     198          (dsphdr) )
     199        (if row
     200            (begin
     201              (dsprow rowno (if (vector? row) (vector->list row) row))
     202              (set! rowno (add1 rowno)) )
     203            (begin
     204              (dsptlr)
     205              (dspbtm)
     206              (set! rowno #f) ) ) ) ) )
     207
     208;;
     209
     210(header '(header-list header-score))
     211(trailer '(trailer-list trailer-score))
     212(label '(label-procedure label-width))
     213(border '(top-procedure bottom-procedure left-string right-string))
     214(space '(inside outside))
     215(row '(widths formatting))
     216(output #t))
     217
     218;;
     219
     220(define (make-display-tabulator
     221          #!key
     222          (header '(header-list header-score))
     223          (trailer '(trailer-list trailer-score))
     224          (label '(label-procedure label-width))
     225          (border '(top-procedure bottom-procedure left-string right-string))
     226          (space '(inside outside))
     227          (row '(widths formatting))
     228          (output #t))
     229  ;
     230  (when header
     231    (unless (or (null? header)
     232                (and (pair? header)
     233                     (= 2 (length header))
     234                     (every string? (car header))
     235                     (character? (cadr header)) ) )
     236      (error 'make-display-tabulator "invalid header specification" header) ) )
     237  (when trailer
     238    (unless (or (null? trailer)
     239                (and (pair? trailer)
     240                     (= 2 (length trailer))
     241                     (every string? (car trailer))
     242                     (character? (cadr trailer)) ) )
     243      (error 'make-display-tabulator "invalid trailer specification" trailer) ) )
     244  (when label
     245    (unless (or (null? label)
     246                (and (pair? label)
     247                     (= 2 (length label))
     248                     (procedure? (car label))
     249                     (spacing? (cadr label)) ) )
     250      (error 'make-display-tabulator "invalid label specification" label) ) )
     251  (when border
     252    (unless (or (null? border)
     253                (and (pair? border)
     254                     (= 4 (length border))
     255                     (procedure? (car border))
     256                     (procedure? (cadr border))
     257                     (string? (caddr border))
     258                     (string? (cadddr border)) ) )
     259      (error 'make-display-tabulator "invalid border specification" border) ) )
     260  (when space
     261    (unless (or (null? space)
     262                (and (pair? space)
     263                     (= 2 (length space))
     264                     (string? (car space))
     265                     (string? (cadr space)) ) )
     266      (error 'make-display-tabulator "invalid space specification" space) ) )
     267  (when row
     268    (unless (or (null? row)
     269                (and (pair? row)
     270                     (= 2 (length row))
     271                     (widths? (car row))
     272                     (formatting-specification? (cadr row)) ) )
     273      (error 'make-display-tabulator "invalid row specification" row) ) )
     274  (unless (or (string? output) (boolean? output) (output-port? output))
     275    (error 'make-list-tabular "invalid output" output) )
     276
     277
     278
     279;;;
     280
     281;;
     282
     283(define (%display-list-tabular header rows widths formatting spacing port)
    105284  (let* (
    106285                [disp-fill
     
    117296          (for-each (lambda (dat fmt wid)
    118297                      (disp-str (format #f fmt dat) wid) )
    119                     (if (vector? row) (vector->list row) row) formatting widths)
     298                    row formatting widths)
    120299          (newline) )]
    121300                [disp-bars
     
    132311      (disp-bars) )
    133312    ;
    134     (for-each (cut disp-row <>) rows) ) )
     313    (while* (rows)
     314      (disp-row it) ) ) )
    135315
    136316;;
     
    144324          (port #t))
    145325  (let ([colcnt
    146           (fold
    147            (lambda (row cnt)
    148              (max cnt
    149                   (cond [(list? row)    (length row)]
    150                         [(vector? row)  (vector-length row)]
    151                         [else
    152                           (error 'display-list-tabular "invalid row" row)])) )
    153            0
    154            rows)])
     326          (if (procedure? rows)
     327              0
     328              (fold
     329               (lambda (row cnt)
     330                 (max cnt
     331                      (cond [(list? row)        (length row)]
     332                            [(vector? row)      (vector-length row)]
     333                            [else
     334                              (error 'display-list-tabular "invalid row" row)])) )
     335               0
     336               rows) ) ] )
    155337    ;
    156338    (unless (and (list? header) (every string? header))
     
    165347      (error 'display-list-tabular "invalid port" port) )
    166348    ;
    167     (%display-list-tabular rows
     349    (%display-list-tabular (if (procedure? rows)
     350                               rows
     351                               (let ([rows rows])
     352                                 (lambda ()
     353                                   (and (not (null? rows))
     354                                        (let ([row (car rows)])
     355                                          (if (vector? row)
     356                                              (vector->list row)
     357                                              row )
     358                                          (set! rows (cdr rows)) ) ) ) ) )
    168359                           header
    169360                           (extend-list widths colcnt (list-tabular-widths))
  • tabular-list/trunk/tabular-list.wiki

    r6457 r6459  
    4444 [procedure] (display-list-tabular ROWS [#:header HEADER] [#:widths WIDTHS] [#:formatting FORMATTING] [#:spacing SPACING] [#:port PORT])
    4545
    46 Display the data in the list {{ROWS}} in a tabular form. The {{ROWS}} must be a
    47 list of lists of objects (columns).
     46Display the data in the list {{ROWS}} in a tabular form. The {{ROWS}} must be
     47either a procedure returning a list of objects or {{#f}} for no more rows, or a
     48list of lists and/or vectors of objects.
    4849
    4950The optional keyword parameter {{HEADER}} must be a list of strings, one for
     
    5960of columns the last format-string is duplicated for the remaining columns. When
    6061missing the {{(list-tabular-formatting)}} value is used.
     62
     63When {{ROWS}} is a procedure the {{WIDTHS}} and {{FORMATTING}} must have
     64elements for all possible columns.
    6165
    6266The optional keyword parameter {{SPACING}} must be a positive-exact-integer.
     
    8084
    8185As {{display-list-tabular}} but with optional instead of keyword paramters.
    82 
    83 ==== %display-list-tabular
    84 
    85  [procedure] (%display-list-tabular ROWS HEADER WIDTHS FORMATTING SPACING PORT)
    86 
    87 As {{*display-list-tabular}} but with required instead of optional paramters.
    88 
    8986
    9087== Examples
Note: See TracChangeset for help on using the changeset viewer.