Extended Format Numeric Input
Howdy!
So, Doug Hoyte's new book "Let Over Lambda" inspired me to do something about this lacking in Lisp... Mucho gracias to Doug for the inspiration, and Edi Weitz for PPCRE!!
Still not quite as convenient as in Forth, but not too bad. The colons require quoting, as in #n|23:59:56|, #n|-110:43|.
But I didn't stop there. I also added support for hyphenated number #n390-3995, underscore and comma separators in long numbers #n123_456_789, #n1.005_003, and #nX1234_5678 or #n|123,456.890| (quotes needed for comma sepators), date entry as in #n2009/03/19 -- and for us Americans #n3/19/09, and complex number input as in #n1.3-2.7j and 3.5i. And a lot of other variations on these themes.
Perhaps you all will find this useful too... (or perhaps I'm the only one who didn't already have this stuff?)
The code that follows is all contained in an eval-when clause because so many of the defuns and macros are needed by the compiler along the way. There are a couple of non-Doug goodies in there too -- such as bang-A symbols to indicate anaphora that should become interned into the package that uses anaphoric macros, instead of requiring you to import those symbols when your compiler complains about unbound anaphoric symbols. Not needed here, per se, but I didn't feel like going through the code and removing references to defmacro/a!.
BTW: Doug's book is near mandatory reading for any serious Lisper, except for those old dogs who already knew all that stuff about macros!
;; -----------------------------------------------------------
;; tools needed to support Doug Hoyte's DEFMACRO!
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun collect-if (predicate proseq &rest rest)
(apply 'remove-if-not predicate proseq rest))
;; --------------------------------------------
;; Bang-symbols
(defun bang-symbol-p (prefix s)
(and (symbolp s)
(> (length (symbol-name s)) 2)
(string= (symbol-name s) prefix
:start1 0
:end1 2)))
(defun get-bang-symbols (prefix body)
(remove-duplicates
(collect-if (curry #'bang-symbol-p prefix) (flatten body))))
(defun bang-symbol-name (s)
(subseq (symbol-name s) 2))
;; --------------------------------------------
(defun raw-mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args)
(princ a s))
))
(defun mkstr (&rest args)
(with-standard-io-syntax
(apply #'raw-mkstr args)))
(defun correct-for-symbol-character-case (str)
;; a portable way to make symbol strings
;; Modern Mode vs ANSI
(if (eql #\a (char (string :a) 0))
(string-downcase (string str))
(string-upcase (string str))))
(defun intern-symbol (str &rest package)
(apply #'intern (correct-for-symbol-character-case str) package))
(defun symb (&rest args)
(values (intern-symbol (apply #'mkstr args))))
;; --------------------------------------------
(defun |reader-for-#`| (stream sub-char numarg)
(declare (ignore sub-char))
(unless numarg (setq numarg 1))
`(lambda ,(loop for i from 1 to numarg
collect (symb 'a i))
,(funcall
(get-macro-character #\`) stream nil)))
(set-dispatch-macro-character
#\# #\` #'|reader-for-#`|)
;; --------------------------------------------
;; A-Bang symbols -- create anaphoric symbol names
;; in package of macro expansion
(defmacro defmacro/a! (name args &body body)
(let ((syms (get-bang-symbols #.(symbol-name :A!) body)))
`(defmacro ,name ,args
(let ,(mapcar #`(,a1 (intern ,(bang-symbol-name a1))) syms)
,@body))))
;; --------------------------------------------
;; G-Bang symbols -- auto generated gensyms
(defmacro defmacro/g! (name args &body body)
(let ((syms (get-bang-symbols #.(symbol-name :G!) body)))
`(defmacro/a! ,name ,args
(let ,(mapcar #`(,a1 (gensym ,(bang-symbol-name a1))) syms)
,@body))))
;; --------------------------------------------
;; O-Bang symbols -- once-only eval gensyms
(defun o!-symbol-to-g!-symbol (s)
(symb #.(symbol-name :G!)
(bang-symbol-name s)))
(defmacro defmacro! (name args &body body)
(let* ((os (get-bang-symbols #.(symbol-name :O!) args))
(gs (mapcar #'o!-symbol-to-g!-symbol os)))
`(defmacro/g! ,name ,args
`(let ,(mapcar #'list (list ,@gs) (list ,@os))
,(progn
,@body)))
))
;; ---------------------------------------
;; This part from Doug Hoyte using Edi's ppcre
#+cl-ppcre
(defmacro! match-mode-ppcre-lambda-form (o!args)
``(lambda (,',g!str)
(cl-ppcre:scan
,(car ,g!args)
,',g!str)))
#+cl-ppcre
(defmacro! subst-mode-ppcre-lambda-form (o!args)
``(lambda (,',g!str)
(cl-ppcre:regex-replace-all
,(car ,g!args)
,',g!str
,(cadr ,g!args))))
#+cl-ppcre
(defun |reader-for-#~| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((mode-char (read-char stream)))
(cond
((char= mode-char #\m)
(match-mode-ppcre-lambda-form
(segment-reader stream
(read-char stream)
1)))
((char= mode-char #\s)
(subst-mode-ppcre-lambda-form
(segment-reader stream
(read-char stream)
2)))
(t (error "Unknown #~~ mode character")))))
#+cl-ppcre
(set-dispatch-macro-character #\# #\~ #'|reader-for-#~|)
;; --------------------------------------------------------------
;; Allow extended number syntax:
;; - embedded underscore separators 123_445.789_443
;; - allow 1+2j or 1-2j or just 2j, where j in [jJiI]
;; - allow dates in yyyy/mm/dd format
;; - allow sexigisimal time in |hh:mm:ss.ss| format (bars needed because of #\:)
;; - allow hyphenated numbers as in telephone numbers, SSN's, and UUID's
(defun remove-separators (s)
(delete #\, (delete #\_ s)))
(defun match-number (s)
(multiple-value-bind (start end)
(#~m/^[+-]?[0-9][0-9_,]*(\.[0-9_,]*([eEdD][+-]?[0-9]+)?)?/ s)
(when start
(values (read-from-string (remove-separators (subseq s start end)))
(subseq s end))
)))
(defun match-complex-ij (s)
(#~m/^[iIjJ]$/ s))
(defun convert-real-or-complex (s)
(multiple-value-bind (val srest)
(match-number s)
(when val
(cond ((= 0 (length srest)) val)
((match-complex-ij srest) (complex 0 val))
((multiple-value-bind (ival sresti)
(match-number srest)
(and ival
(match-complex-ij sresti)
(complex val ival))))
(t nil)))
))
(defun convert-sexigisimal (s)
;; hh:mm:ss.ss, or hh:mm
(multiple-value-bind (start end gstart gend)
(#~m/^([+-])?([0-9]+):([0-9][0-9]?)(:[0-9][0-9]?(\.[0-9_,]*)?)?$/ s)
(declare (ignore end))
(when start
(symbol-macrolet
((sign (aref gstart 0))
(hstart (aref gstart 1))
(hend (aref gend 1))
(mstart (aref gstart 2))
(mend (aref gend 2))
(sstart (aref gstart 3))
(send (aref gend 3))
(sfrac (aref gstart 4)))
(ignore-errors
(let* ((hh (read-from-string (subseq s hstart hend)))
(mm (read-from-string (subseq s mstart mend)))
(ss (if sstart
(read-from-string (remove-separators
(subseq s (1+ sstart) send)))
0))
(val (+ (* 60 (+ (* 60 hh) mm))
(if sfrac
(float ss 1d0)
ss))))
(if (and sign
(char= (char s sign) #\-))
(- val)
val)
))))))
(defun convert-date (s)
;; yyyy/mm/dd
(multiple-value-bind (start end gstart gend)
(#~m%^([0-9][0-9][0-9][0-9])/([0-9][0-9]?)/([0-9][0-9]?)$% s)
(declare (ignore end))
(when start
(symbol-macrolet
((ystart (aref gstart 0))
(yend (aref gend 0))
(mstart (aref gstart 1))
(mend (aref gend 1))
(dstart (aref gstart 2))
(dend (aref gend 2)))
(ignore-errors
(let* ((yyyy (read-from-string (subseq s ystart yend)))
(mm (read-from-string (subseq s mstart mend)))
(dd (read-from-string (subseq s dstart dend))))
(encode-universal-time 0 0 0 dd mm yyyy)
))))))
(defun convert-american-short-date (s)
;; mm/dd/yy
(multiple-value-bind (start end gstart gend)
(#~m%^([0-9][0-9]?)/([0-9][0-9]?)/([0-9][0-9]?)$% s)
(declare (ignore end))
(when start
(symbol-macrolet
((ystart (aref gstart 2))
(yend (aref gend 2))
(mstart (aref gstart 0))
(mend (aref gend 0))
(dstart (aref gstart 1))
(dend (aref gend 1)))
(ignore-errors
(let* ((yyyy (read-from-string (subseq s ystart yend)))
(mm (read-from-string (subseq s mstart mend)))
(dd (read-from-string (subseq s dstart dend))))
(encode-universal-time 0 0 0 dd mm yyyy)
))))))
(defun convert-hyphenated-number (s)
;; xxxx-xx-xxxx as in telephone numbers, SSN's, and UUID's
(if (#~m/^[0-9]+(\-[0-9]+)*$/ s)
(read-from-string (delete #\- s))))
(defun convert-other-base-number (s)
;; #xNNNN_NNNN_NNN
(when (or (#~m/^[xXoObB]/ s)
(#~m/^[0-9]+[rR]/ s))
(ignore-errors
(read-from-string (format nil "#~A" (remove-separators s))))))
(defun |reader-for-#n| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((v (read stream t nil t)))
(if (symbolp v)
(let ((s (symbol-name v)))
(cond ((convert-real-or-complex s))
((convert-sexigisimal s))
((convert-date s))
((convert-american-short-date s))
((convert-hyphenated-number s))
((convert-other-base-number s))
(t v)))
;; else -- not a symbol (!?)
v)))
(set-dispatch-macro-character
#\# #\n #'|reader-for-#n|) ) ;; end of eval-when
;; --------------------------------------
Dr. David McClain
Chief Technical Officer
Refined Audiometrics Laboratory
4391 N. Camino Ferreo
Tucson, AZ 85750
email: dbm@refined-audiometrics.com
phone: 1.520.390.3995