;;; $Id$
;;;
;;; C-scanf() like (format) analogon for input from strings.
;;;


(proclaim '(optimize (speed 3) (safety 0) (space 0)))

(eval-when (:load-toplevel
	    :compile-toplevel
	    :execute)

(defmacro with-type (type expr)
  `(the ,type ,(if (atom expr)
                   expr
                   (expand-call type (binarize expr)))))

(defun expand-call (type expr)
  `(,(car expr) ,@(mapcar #'(lambda (a)
                              `(with-type ,type ,a))
                          (cdr expr))))

(defun binarize (expr)
  (if (and (nthcdr 3 expr)
           (member (car expr) '(+ - * /)))
      (destructuring-bind (op a1 a2 . rest) expr
        (binarize `(,op (,op ,a1 ,a2) ,@rest)))
      expr))
)


(defparameter whitespace-characters

  #(#\Space #\Newline #\Tab
    #\Linefeed #\Return #\Page
    #\Backspace #\Rubout)		; questionable

  "Vector of all space-like characters like tab and newline.")


(defun whitespace-char-p (c)

  "Returns non-nil iff c is a non visible character like space or newline."

  (position c whitespace-characters))


(defun skip-charset (charset str &key (start 0) (end nil))

  "Returns the position of the first character in str which is not
element of charset. When end is specified then it must not be greater
than the length of the string. Returns end or length of str when str
consists entirely of elements of charset."

  (or (position-if-not #'(lambda (c) (position c charset))
		       str :start start :end end)
      end))

(defun scan-charset (charset str &key (start 0) (end nil))
  (or (position-if #'(lambda (c) (position c charset))
		   str :start start :end end)
      end))


(defun isolate-word (str &key (start 0) (end nil))

  "Reads a whitespace delimited word from the string."

  (declare (string str))
  (let* ((len (let ((l (length str)))
		(if end (min l end) l)))
	 (i (position-if-not #'whitespace-char-p str
			     :start start :end len))
	 (j (position-if #'whitespace-char-p str
			 :start i :end len)))
    (values (subseq str i j) j)))


(defun string-to-unsigned-fixnum (str &key (start 0) (end nil) (radix 10))

  "Converts part of a string str to an unsigned fixnum.

Starts converting at position start, stops at end when specified or at
end of string or when a non-convertible character is seen. If end is
specified then it must not be greater than the length of the string.

Assumes the specified radix and does neither recognize a radix
encoding in the string nor a sign nor even leading whitespace.

Returns the converted number and the position of the first character
in the string behind that number. Returns 0 when no convertible
characters where seen at all."

  (declare (simple-string str)
           (fixnum start radix))
  (let ((len (or end (length str))))
    (declare (fixnum len))
    (do ((i start (1+ i))
         (n 0))
        ((= i len)
         (values n i))
      (declare (fixnum i n))
      (let ((d (digit-char-p (schar str i) radix)))
        (if d
            (setq n (with-type fixnum (+ d (* n radix))))
            (return (values n i)))))))


(defun string-to-unsigned-integer (str &key (start 0) (end nil) (radix 10))

  "Converts part of a string str to an integer.

Starts converting at position start, stops at end when specified or at
end of string or when a non-convertible character is seen. If end is
specified then it must not be greater than the length of the string.

Assumes the specified radix and does neither recognize a radix
encoding in the string nor a sign nor even leading whitespace.

Returns the converted number and the position of the first character
in the string behind that number. Returns nil when no convertible
characters where seen at all."

  (declare (simple-string str)
           (fixnum start end radix))
  (let ((len (or end (length str))))
    (do ((i start (1+ i))
         (n 0))
        ((= i len)
         (values n len))
      (let ((d (digit-char-p (schar str i) radix)))
        (if d
            (setq n (with-type integer (+ d (* n radix))))
            (return (if (> i start)
			(values n i))))))))


(defun string-to-integer (str &key (start 0) (end nil) (radix 10))

  "Converts part of a simple-string str to an integer.

Skips leading whitespace and recognizes #\+ and #\- as signs.

Converts up to end (if specified) or end of string or until a
non-convertible character is seen, whichever comes first.

Uses the specified radix as number conversion base. Alas the specified
radix may be overridden from the input in the string using a syntax of
#x, #o, #b, #nnr for hex, octal, binary or other.

Returns nil on error or the resulting integer and the position of the
first character behind the integer."

  (declare (simple-string str)
	   (fixnum start radix))
  (block nil
    (let* ((len (let ((l (length str)))
		  (if end (min l end) l)))
	   (i (position-if-not #'whitespace-char-p str
			       :start start :end len))
	   (negative nil)
	   (n nil))
      (declare (fixnum len i))
      (when (= i len)
	(return nil))
      (case (schar str i)
	(#\- (setq negative t)
	     (incf i)
	     (when (= i len)
	       (return nil)))
	(#\+ (incf i)
	     (when (= i len)
	       (return nil))))
      (when (char= #\# (schar str i))
	(incf i)
	(if (= i len)
	    (return nil))
	(case (schar str i)
	  (#\b (incf i) (setf radix #b10))
	  (#\o (incf i) (setf radix #o10))
	  (#\x (incf i) (setf radix #x10))
	  (t (multiple-value-setq (radix i)
	       (string-to-unsigned-fixnum str :start i :end end))
	     (when (or (not radix)
		       (< radix 2)
		       (= i len)
		       (char-not-equal (schar str i) #\r))
	       (return nil))
	     (incf i))))
      (multiple-value-setq (n i)
	(string-to-unsigned-integer str :start i :end end :radix radix))
      (when (not n)
	(return nil))
      (values (if negative (- n) n) i))))


(defun string-to-float (str &key (start 0) (end nil))

  "(str &key (start 0) (end nil))

Read a double float from the string str. Start reading at start, stop
at end or at end of string or when the first non-convertible character
is seen. Assumes decimal. Returns the converted number and the
position of the first character in str following the converted
number. Returns nil on error."

  (declare (simple-string str)
	   (fixnum start))
  (block nil
    (let* ((len (let ((l (length str)))
		  (if end (min l end) l)))
	   (i (position-if-not #'whitespace-char-p str
			       :start start :end len))
	   negative
	   entier
	   fractional
	   fractional-digits
	   exponent
	   exponent-negative
	   result)
      (declare (fixnum len i))

      ;; Find sign.
      (when (= i len)
	(return nil))
      (case (schar str i)
	(#\- (setq negative t)
	     (incf i)
	     (when (= i len)
	       (return nil)))
	(#\+ (incf i)
	     (when (= i len)
	       (return nil))))

      ;; Find integer part.
      (multiple-value-setq (entier i)
	(string-to-unsigned-integer str :start i :end end))

      ;; Find fractional part.
      (when (and (< i len)
		 (char= (schar str i) #\.))
	(incf i)
	(setq fractional-digits i)
	(multiple-value-setq (fractional i)
	  (string-to-unsigned-integer str :start i :end end))
	(setq fractional-digits (- fractional-digits i)))

      ;; Ignore missing entier or fractional part but not both.
      (if entier
	  (unless fractional
	    (setq fractional 0))
	  (if fractional
	      (setq entier 0)
	      (return nil)))

      ;; Find exponent.
      (when (and (< i len)
		 (char-equal (schar str i) #\e))
	(incf i)
	(when (= i len)
	  (return nil))
	;; Find sign of exponent.
	(case (schar str i)
	  (#\- (setq exponent-negative t)
	       (incf i)
	       (when (= i len)
		 (return nil)))
	  (#\+ (incf i)
	       (when (= i len)
		 (return nil))))
	;; Find magnitude of exponent.
	(multiple-value-setq (exponent i)
	  (string-to-unsigned-integer str :start i :end end))
	;; Check exponent, apply sign.
	(when (not exponent)
	  (return nil))
	(when exponent-negative
	  (setq exponent (- exponent))))

      ;; Assemble result.
      (setq result (float entier 0d0))
      (when fractional-digits
	(incf result (* fractional (expt 1d1 fractional-digits))))
      (when exponent
	(setq result (* result (expt 10 exponent))))
      (values (if negative (- result) result) i))))

(defun stream-parse-integer (strm &optional (base 10))
  (do* ((n 0
	   (+ (* base n) d))
	(c (read-char strm nil nil)
	   (read-char strm nil nil))
	(d (and c (digit-char-p c base))
	   (and c (digit-char-p c base))))
       ((not d)
	(if c (unread-char c strm))
	n)))

(defun scan-strm-strm (form strm)
  (let (result)
    (labels
        ((scan-character (width)
           (push (read-char strm) result))
         (scan-string (width)
           (push (read-char strm) result))
         (scan-integer (width)
           (push (stream-parse-integer strm) result))
         (scan-float (width)
           (push (stream-parse-integer strm) result))
         (dispatch (c)
           (case c
             (#\~
              (let ((width (stream-parse-integer form))
                    (form-char (read-char form nil nil)))
                (case form-char
                  (#\c (scan-character width))
                  (#\s (scan-string width))
                  (#\d (scan-integer width))
                  (#\f (scan-float width))
                  (otherwise nil))))
             (otherwise
              (let ((d (read-char strm)))
                (eq c d))))))
      (do* ((c (read-char form nil nil)
               (read-char form nil nil)))
           ((or (not c)
                (not (dispatch c)))
            (if c
                ;; EOF in form not hit, means error, return nil.
                nil
                ;; EOF in form, means all formats processed.
                ;; Return reversed result list.
                (values-list (nreverse result))))))))

(defun scan-string-strm (form strm)
  (with-input-from-string (form-strm form)
    (scan-strm-strm form-strm strm)))

(defun scan-string-string (form string)
  (with-input-from-string (strm string)
    (scan-string-strm form strm)))

(defun read-daxa ()
  (with-open-file (daxa "daxa.asc"
                        :direction :input)
    (do ((line (read-line daxa nil nil)
               (read-line daxa nil nil))
         (result nil
                 (cons (multiple-value-list
                           (scan-string-string
                            "~2d~2d~2d,~3d.~3d,~3d.~3d,~3d.~3d,~3d.~3d"
                            line))
                       result)))
        ((not line) result))))