number.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :xuriella)
  31
  32 (define-instruction xsl:number (args env)
  33   (destructuring-bind (&key level count from value format lang letter-value
  34                             grouping-separator grouping-size)
  35       args
  36     (let ((count (and count (compile-pattern count env)))
  37           (from  (and from (compile-pattern from env)))
  38           (value (and value (compile-xpath value env)))
  39           (format       (compile-avt (or format "1") env))
  40           (lang         (compile-avt (or lang "") env))
  41           (letter-value (compile-avt (or letter-value "foo") env))
  42           (grouping-separator
  43            (and grouping-separator (compile-avt grouping-separator env)))
  44           (grouping-size (and grouping-size (compile-avt grouping-size env))))
  45       (lambda (ctx)
  46         (let ((value              (when value
  47                                     (round (xpath:number-value
  48                                             (funcall value ctx)))))
  49               (format             (funcall format ctx))
  50               (lang               (funcall lang ctx))
  51               (letter-value       (funcall letter-value ctx))
  52               (grouping-separator (when grouping-separator
  53                                     (funcall grouping-separator ctx)))
  54               (grouping-size      (when grouping-size
  55                                     (funcall grouping-size ctx))))
  56           (write-text
  57            (format-number-list
  58             (if value
  59                 (list value)
  60                 (compute-number-list (or level "single")
  61                                      (xpath::context-node ctx)
  62                                      count
  63                                      from))
  64             format
  65             lang
  66             letter-value
  67             grouping-separator
  68             grouping-size)))))))
  69
  70 (defun compile-pattern (str env)
  71   (compile-xpath
  72    `(xpath:xpath
  73      (:union
  74       ,@(mapcar (lambda (x)
  75                   (check-type (car x) (eql :path))
  76                   `(:path (:ancestor-or-self :node)
  77                           ,@(cdr x)))
  78                 (parse-pattern str))))
  79    env))
  80
  81 (defun pattern-thunk-matches-p (pattern-thunk node)
  82   (find node
  83         (xpath:all-nodes (funcall pattern-thunk (xpath:make-context node)))))
  84
  85 (defun ancestors-using-count-and-from (node count from)
  86   (let ((ancestors
  87          (xpath::force
  88           (funcall (xpath::axis-function :ancestor-or-self) node))))
  89     (remove-if-not (lambda (ancestor)
  90                      (pattern-thunk-matches-p count ancestor))
  91                    (if from
  92                        (loop
  93                           for a in ancestors
  94                           when (pattern-thunk-matches-p from a)
  95                           do (return result)
  96                           collect a into result
  97                           finally (return nil))
  98                        ancestors))))
  99
 100 (defun node-position-among-siblings (node count)
 101   (1+
 102    (count-if (lambda (sibling)
 103                (pattern-thunk-matches-p count sibling))
 104              (xpath::force
 105               (funcall (xpath::axis-function :preceding-sibling) node)))))
 106
 107 (defun compute-number-list (level node count from)
 108   (unless count
 109     (setf count
 110           (let ((uri (xpath-protocol:namespace-uri node))
 111                 (lname (xpath-protocol:local-name node)))
 112             (lambda (ctx)
 113               (let ((node (xpath:context-node ctx)))
 114                 (xpath-sys:make-node-set
 115                  (if (and (xpath-protocol:node-type-p node :element)
 116                           (equal (xpath-protocol:namespace-uri node) uri)
 117                           (equal (xpath-protocol:local-name node) lname))
 118                      (list node)
 119                      nil)))))))
 120   (cond
 121     ((equal level "single")
 122      (let ((ancestor (car (ancestors-using-count-and-from node count from))))
 123        (if ancestor
 124            (list (node-position-among-siblings ancestor count))
 125            nil)))
 126     ((equal level "multiple")
 127      (mapcar (lambda (ancestor)
 128                (node-position-among-siblings ancestor count))
 129              (reverse
 130               (ancestors-using-count-and-from node count from))))
 131     ((equal level "any")
 132      (destructuring-bind (root)
 133          (xpath::force (funcall (xpath::axis-function :root) node))
 134        (let ((nodes (xpath::force
 135                      (xpath::append-pipes
 136                       (xpath::subpipe-before
 137                        node
 138                        (funcall (xpath::axis-function :descendant-or-self) root))
 139                       (list node)))))
 140          (when from
 141            (loop
 142               for (current . rest) on nodes
 143               when (pattern-thunk-matches-p from current)
 144               do
 145                 (setf nodes rest)))
 146          (list
 147           (loop
 148              for n in nodes
 149              count (pattern-thunk-matches-p count n))))))
 150     (t
 151      (xslt-error "invalid number level: ~A" level))))
 152
 153 (xpath::deflexer format-lexer
 154   ("([a-zA-Z0-9]+)" (x) (values :format x))
 155   ("([^a-zA-Z0-9]+)" (x) (values :text x)))
 156
 157 (defun format-number-token (str n)
 158   (cond
 159     ((or (equal str "a") (equal str "A"))
 160      (let ((start (if (equal str "a") 96 64)))
 161        (if (zerop n)
 162            (code-char (1+ start))
 163            (nreverse
 164             (with-output-to-string (r)
 165               (loop
 166                  for m = n then rest
 167                  while (plusp m)
 168                  for (rest digit) = (multiple-value-list
 169                                      (truncate m 26))
 170                  do
 171                  (write-char (code-char (+ start digit)) r)))))))
 172     ((equal str "i")
 173      (format nil "~(~@R~)" n))
 174     ((equal str "I")
 175      (format nil "~@R" n))
 176     (t
 177      (unless (cl-ppcre:all-matches "^0*1$" str)
 178        ;; unsupported format
 179        (setf str "1"))
 180      (format nil "~v,'0D" (length str) n))))
 181
 182 (defun group-numbers (str separator size)
 183   (loop
 184      for c across str
 185      for i from (1- (length str)) downto 0
 186      do
 187        (write-char c)
 188        (when (and (zerop (mod i size)) (plusp i))
 189          (write-string separator))))
 190
 191 ;;; fixme: unicode support
 192 (defun format-number-list
 193     (list format lang letter-value grouping-separator grouping-size)
 194   (declare (ignore lang letter-value))
 195   (with-output-to-string (*standard-output*)
 196     (let ((lexer (format-lexer format))
 197           (seen-text-p t)
 198           (last-token nil))
 199       (loop
 200          (multiple-value-bind (type str) (funcall lexer)
 201            (unless type
 202              (if list
 203                  (setf type :format
 204                        str last-token)
 205                  (return)))
 206            (ecase type
 207              (:text
 208               (write-string str)
 209               (setf seen-text-p t))
 210              (:format
 211               (unless seen-text-p
 212                 (write-char #\.))
 213               (setf seen-text-p nil)
 214               (setf last-token str)
 215               (let* ((n (pop list))
 216                      (formatted (format-number-token str n)))
 217                 (write-string (if (and grouping-separator
 218                                        grouping-size)
 219                                   (group-numbers formatted
 220                                                  grouping-separator
 221                                                  grouping-size)
 222                                   formatted))))))))))