;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;; Defines functions to parse any number type, without using the reader
;;;;
;;;; Author: Matthew Danish -- mrd.debian.org
;;;;
;;;; Copyright 2002 Matthew Danish.
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above copyright
;;;;    notice, this list of conditions and the following disclaimer in the
;;;;    documentation and/or other materials provided with the distribution.
;;;; 3. Neither the name of the author nor the names of its contributors
;;;;    may be used to endorse or promote products derived from this software
;;;;    without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;;; SUCH DAMAGE.

(defpackage #:org.mapcar.parse-number
  (:use #:common-lisp)
  (:nicknames #:parse-number)
  (:export #:parse-number
           #:parse-real-number
           #:parse-positive-real-number
           #:invalid-number
           #:invalid-number-value
           #:invalid-number-reason))

(in-package #:org.mapcar.parse-number)

(define-condition invalid-number (parse-error)
  ((value :reader invalid-number-value
          :initarg :value
          :initform nil)
   (reason :reader invalid-number-reason
           :initarg :reason
           :initform "Not specified"))
  (:report (lambda (c s)
             (format s "Invalid number: ~S [Reason: ~A]"
                     (invalid-number-value c)
                     (invalid-number-reason c)))))

(declaim (type cons *white-space-characters*))
(defparameter *white-space-characters*
  '(#\Space #\Tab #\Return #\Linefeed)
  "A list of all of the whitespace characters.")

(declaim (inline white-space-p))
(defun white-space-p (x)
  "Is the given character a whitespace character?"
  (declare (optimize (speed 3) (safety 0))
           (type character x))
  (and (find x *white-space-characters*) t))

(declaim (inline parse-integer-and-places))
(defun parse-integer-and-places (string start end &key (radix 10))
  "Parse an integer and return a 'parsed-integer'. This is an object
   whose numerical value can be accessed with the function
   number-value and whose length can be accessed with the function
   place."
  (declare (optimize (speed 3) (safety 1))
           (type string string)
           (type fixnum start end radix))
  (multiple-value-bind (integer end-pos)
      (if (= start end)
          (values 0 0)
          (parse-integer string
                         :start start
                         :end end
                         :radix radix))
    ;; cl:parse-integer will consume trailing whitespace, thus end-pos may be
    ;; larger than the number of digits. Instead of trimming whitespace
    ;; beforehand we count it here
    (let ((relevant-digits (- end-pos start
                              (loop :for pos :from (- end-pos 1) :downto start
                                 :while (member (char string pos)
                                                *white-space-characters*)
                                 :count 1))))
      (cons integer relevant-digits))))

(defun parse-integers (string start end splitting-points &key (radix 10))
  "Parse a string containing multiple integers where SPLITTING-POINTS
   is a list of locations where each location is inbetween
   consecutive integers. This will return a list of parsed-integers.
   The last parsed-integer will have a negative value for its length."
  (declare (optimize (speed 3) (safety 1))
           (type string string)
           (type fixnum start end radix))
  (values-list (loop for left = start then (1+ right)
                     for point in splitting-points
                     for right = point
                     collect (parse-integer-and-places string
                                                       left
                                                       right
                                                       :radix radix)
                     into integers
                     finally (return
                               (nconc integers
                                      (list
                                       (parse-integer-and-places string
                                                                 left
                                                                 end
                                                                 :radix radix
                                                                 )))))))

(declaim (inline number-value places))
(defun number-value (x) "Get the value of a parsed-integer." (car x))
(defun places (x) "Get the length of a parsed-integer." (cdr x))

;; Numbers which could've been parsed, but intentionally crippled not to:
;; #xFF.AA
;; #o12e3

;; Numbers which CL doesn't parse, but this does:
;; #10r3.2
;; #2r  11

(defun parse-number (string &key (start 0) (end nil) (radix 10)
                                 ((:float-format *read-default-float-format*)
                                  *read-default-float-format*))
  "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec."
  (flet ((invalid-number (reason)
           (error 'invalid-number
                  :value (subseq string start end)
                  :reason reason)))
    (let ((end (or end (length string))))
      (if (and (eql (char string start) #\#)
               (member (char string (1+ start)) '(#\C #\c)))
          (let ((\(-pos (position #\( string :start start :end end))
                (\)-pos (position #\) string :start start :end end)))
            (when (or (not \(-pos)
                      (not \)-pos)
                      (position #\( string :start (1+ \(-pos) :end end)
                      (position #\) string :start (1+ \)-pos) :end end))
              (invalid-number "Mismatched/missing parenthesis"))
            (let ((real-pos (position-if-not #'white-space-p string
                                             :start (1+ \(-pos) :end \)-pos)))
              (unless real-pos
                (invalid-number "Missing real part"))
              (let ((delimiting-space (position-if #'white-space-p string
                                                   :start (1+ real-pos)
                                                   :end \)-pos)))
                (unless delimiting-space
                  (invalid-number "Missing imaginary part"))
                (let ((img-pos (position-if-not #'white-space-p string
                                                :start (1+ delimiting-space)
                                                :end \)-pos)))
                  (unless img-pos
                    (invalid-number "Missing imaginary part"))
                  (let ((img-end-pos (position-if #'white-space-p string
                                                  :start (1+ img-pos)
                                                  :end \)-pos)))
                    (complex (parse-real-number string
                                                :start real-pos
                                                :end delimiting-space
                                                :radix radix)
                             (parse-real-number string
                                                :start img-pos
                                                :end (or img-end-pos
                                                         \)-pos)
                                                :radix radix)))))))
          (parse-real-number string :start start :end end :radix radix)))))

(defun parse-real-number (string &key (start 0) (end nil) (radix 10)
                                      ((:float-format *read-default-float-format*)
                                       *read-default-float-format*))
  "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec -- except for complex numbers."
  (let ((end (or end (length string))))
    (case (char string start)
      ((#\-)
       (* -1 (parse-positive-real-number string
                                         :start (1+ start)
                                         :end end
                                         :radix radix)))
      ((#\+)
       (parse-positive-real-number string
                                   :start (1+ start)
                                   :end end
                                   :radix radix))
      ((#\#)
       (case (char string (1+ start))
         ((#\x #\X)
          (parse-real-number string
                             :start (+ start 2)
                             :end end
                             :radix 16))
         ((#\b #\B)
          (parse-real-number string
                             :start (+ start 2)
                             :end end
                             :radix 2))
         ((#\o #\O)
          (parse-real-number string
                             :start (+ start 2)
                             :end end
                             :radix 8))
         (t (if (digit-char-p (char string (1+ start)))
                (let ((r-pos (position #\r string
                                       :start (1+ start)
                                       :end end
                                       :key #'char-downcase)))
                  (unless r-pos
                    (error 'invalid-number
                           :value (subseq string start end)
                           :reason "Missing R in #radixR"))
                  (parse-real-number string
                                     :start (1+ r-pos)
                                     :end end
                                     :radix (parse-integer string
                                                           :start (1+ start)
                                                           :end r-pos)))))))
      (t (parse-positive-real-number string
                                     :start start
                                     :end end
                                     :radix radix)))))

(defun base-for-exponent-marker (char)
  "Return the base for an exponent-marker."
  (case char
    ((#\d #\D)
     10.0d0)
    ((#\e #\E)
     (coerce 10 *read-default-float-format*))
    ((#\f #\F)
     10.0f0)
    ((#\s #\S)
     10.0s0)
    ((#\l #\L)
     10.0l0)))

(defun make-float/frac (radix exp-marker whole-place frac-place exp-place)
  "Create a float using EXP-MARKER as the exponent-marker and the
   parsed-integers WHOLE-PLACE, FRAC-PLACE, and EXP-PLACE as the
   integer part, fractional part, and exponent respectively."
  (let* ((base (base-for-exponent-marker exp-marker))
         (exp (expt base (number-value exp-place))))
    (+ (* exp (number-value whole-place))
       (/ (* exp (number-value frac-place))
          (expt (float radix base)
                (places frac-place))))))

(defun make-float/whole (exp-marker whole-place exp-place)
  "Create a float where EXP-MARKER is the exponent-marker and the
   parsed-integers WHOLE-PLACE and EXP-PLACE as the integer part and
   the exponent respectively."
  (* (number-value whole-place)
     (expt (base-for-exponent-marker exp-marker)
           (number-value exp-place))))

(defun parse-positive-real-number (string &key (start 0) (end nil) (radix 10)
                                               ((:float-format *read-default-float-format*)
                                                *read-default-float-format*))
  "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec -- except for complex numbers and negative numbers."
  (let ((end (or end (length string)))
        (first-char (char string start)))
    (flet ((invalid-number (reason)
             (error 'invalid-number
                    :value (subseq string start end)
                    :reason reason)))
      (when (position-if #'white-space-p string
                         :start (position-if-not #'white-space-p string
                                                 :start start
                                                 :end end)
                         :end   (position-if-not #'white-space-p string
                                                 :start start
                                                 :end end
                                                 :from-end t))
        (invalid-number "Whitespace inside the number"))
      (case first-char
        ((#\-)
         (invalid-number "Invalid usage of -"))
        ((#\/)
         (invalid-number "/ at beginning of number"))
        ((#\d #\D #\e #\E #\l #\L #\f #\F #\s #\S)
         (when (= radix 10)
           (invalid-number "Exponent-marker at beginning of number"))))
      (let (/-pos .-pos exp-pos exp-marker)
        (loop for index from start below end
              for char = (char string index)
              do (case char
                   ((#\/)
                    (if /-pos
                        (invalid-number "Multiple /'s in number")
                        (setf /-pos index)))
                   ((#\.)
                    (if .-pos
                        (invalid-number "Multiple .'s in number")
                        (setf .-pos index)))
                   ((#\e #\E #\f #\F #\s #\S #\l #\L #\d #\D)
                    ;; We should only execute this if the base is
                    ;; not used for the given radix (ie the digit
                    ;; e is valid in base 15 and up).
                    (when (>= (+ 10
                                 (- (char-code (char-upcase char))
                                    (char-code #\A)))
                              radix)
                      (when exp-pos
                        (invalid-number
                         "Multiple exponent-markers in number"))
                      (setf exp-pos index)
                      (setf exp-marker (char-downcase char)))))
              when (eql index (1- end))
              do (case char
                   ((#\/)
                    (invalid-number "/ at end of number"))
                   ((#\d #\D #\e #\E #\s #\S #\l #\L #\f #\F)
                    (when (= radix 10)
                      (invalid-number "Exponent-marker at end of number")))))
        (cond ((and /-pos .-pos)
               (invalid-number "Both . and / cannot be present simultaneously"))
              ((and /-pos exp-pos)
               (invalid-number "Both an exponent-marker and / cannot be present simultaneously"))
              ((and .-pos exp-pos)
               (if (< exp-pos .-pos)
                   (invalid-number "Exponent-markers must occur after . in number")
                   (if (/= radix 10)
                       (invalid-number "Only decimal numbers can contain exponent-markers or decimal points")
                       (multiple-value-bind (whole-place frac-place exp-place)
                           (parse-integers string start end
                                           (list .-pos exp-pos)
                                           :radix radix)
                         (make-float/frac radix exp-marker whole-place frac-place exp-place)))))
              (exp-pos
               (if (/= radix 10)
                   (invalid-number "Only decimals can contain exponent-markers")
                   (multiple-value-bind (whole-place exp-place)
                       (parse-integers string start end
                                       (list exp-pos)
                                       :radix radix)
                     (make-float/whole exp-marker whole-place exp-place))))
              (/-pos
               (multiple-value-bind (numerator denominator)
                   (parse-integers string start end
                                   (list /-pos)
                                   :radix radix)
                 (if (>= (number-value denominator) 0)
                     (/ (number-value numerator)
                        (number-value denominator))
                     (invalid-number "Misplaced - sign"))))
              (.-pos
               (if (/= radix 10)
                   (invalid-number "Only decimal numbers can contain decimal points")
                   (multiple-value-bind (whole-part frac-part)
                       (parse-integers string start end
                                       (list .-pos)
                                       :radix 10)
                     (cond
                       ((minusp (places frac-part))
                        (if (and (zerop (number-value whole-part))
                                 (zerop (places whole-part)))
                            (invalid-number "Only the . is present")
                            (number-value whole-part)))
                       ((>= (number-value frac-part) 0)
                        (coerce (+ (number-value whole-part)
                                   (/ (number-value frac-part)
                                      (expt 10 (places frac-part))))
                                *read-default-float-format*))
                       (t
                        (invalid-number "Misplaced - sign"))))))
              (t
               (values (parse-integer string
                                      :start start
                                      :end end
                                      :radix radix))))))))
