How to make this code simpler, clearer and "more lispy"? - common-lisp

I want to parse the text line from the Wavefront OBJ file. Currently I am interested in "V" and "F" types only.
My algorithm is as follows:
check if line is not nil (otherwise step 2 would fail)
drop comment after "#" and trim spaces
drop prefix "v " or "f "
split string to the list of elements where each element
is split to the list if it is symbol like |34/76/23|
is converted from the list: I take one element only, the first by default
or coerced to the given type if it is atomic number already.
Here is the code:
(defun parse-line (line prefix &key (type 'single-float))
(declare (optimize (debug 3)))
(labels ((rfs (what)
(read-from-string (concatenate 'string "(" what ")")))
(unpack (str &key (char #\/) (n 0))
(let ((*readtable* (copy-readtable)))
(when char ;; we make the given char a delimiter (space)
(set-syntax-from-char char #\Space))
(typecase str
;; string -> list of possibly symbols.
;; all elements are preserved by (map). nil's are dropped
(string (delete-if #'null
(map 'list
#'unpack
(rfs str))))
;; symbol -> list of values
(symbol (unpack (rfs (symbol-name str))))
;; list -> value (only the requested one)
(list (unpack (nth n str)))
;; value -> just coerce to type
(number (coerce str type))))))
(and line
(setf line (string-trim '(#\Space #\Tab)
(subseq line 0 (position #\# line))))
(< (length prefix) (length line))
(string= line prefix :end1 (length prefix) :end2 (length prefix))
(setf line (subseq line (length prefix)))
(let ((value (unpack line :char nil)))
(case (length value)
(3 value)
(4 (values (subseq value 0 3) ;; split quad 0-1-2-3 on tri 0-1-2 + tri 0-2-3
(list (nth 0 value)
(nth 2 value)
(nth 3 value)))))))))
Step four (label "unpack") is kind of recursive. It is one function and can call itself three times.
Anyway, this solution seems to be clunky.
My question is: how should one solve this task with shorter and clearer code?

I would approach this in a more structured manner.
You want to parse an obj file into some sort of data structure:
(defun parse-obj-file (filespec)
;; todo
)
You need to think about how the data structure returned should look. For now, let us return a list of two lists, one of the vertices, one of the faces. The parser will go through each line, determine whether it is either a vertex or a face, and then collect it into the appropriate list:
(defun parse-obj-file (filespec)
(with-open-file (in-stream filespec
:direction :input)
(loop for line = (read-line in-stream nil)
while line
when (cl-ppcre:scan "^v " line)
collect (parse-vertex line) into vertices
when (cl-ppcre:scan "^f " line)
collect (parse-face line) into faces
finally (return (list vertices faces)))))
I used the cl-ppcre library here, but you could also use mismatch or search. You will then need to define parse-vertex and parse-face, for which cl-ppcre:split should come in quite handy.
It would perhaps also be useful to define classes for vertices and faces.
Update: This is how I would approach vertices:
(defclass vertex ()
((x :accessor x :initarg :x)
(y :accessor y :initarg :y)
(z :accessor z :initarg :z)
(w :accessor w :initarg :w)))
(defun parse-vertex (line)
(destructuring-bind (label x y z &optional w)
(cl-ppcre:split "\\s+" (remove-comment line))
(declare (ignorable label))
(make-instance 'vertex
:x (parse-number x)
:y (parse-number y)
:z (parse-number z)
:w (parse-number w))))
Parse-number is from the parse-number library. It is better than using read.
Update 2: (Sorry for making this a run-on story; I have to interlace some work.) A face consists of a list of face-points.
(defclass face-point ()
((vertex-index :accessor vertex-index :initarg :vertex-index)
(texture-coordinate :accessor texture-coordinate
:initarg :texture-coordinate)
(normal :accessor normal :initarg :normal)))
(defun parse-face (line)
(destructuring-bind (label &rest face-points)
(cl-ppcre:split "\\s+" (remove-comment line))
(declare (ignorable label))
(mapcar #'parse-face-point face-points)))
(defun parse-face-point (string)
(destructuring-bind (vertex-index &optional texture-coordinate normal)
(cl-ppcre:split "/" string)
(make-instance 'face-point
:vertex-index vertex-index
:texture-coordinate texture-coordinate
:normal normal)))
Remove-comment simply throws away everything after the first #:
(defun remove-comment (line)
(subseq line 0 (position #\# line)))

Related

Common lisp macro not calling function

I am working on a complicated macro and have run into a roadblock.
(defmacro for-each-hashtable-band (body vars on &optional counter name)
`(block o
(with-hash-table-iterator (next-entry ,on)
(destructuring-bind
,(apply #'append vars)
(let ((current-band (list ,#(mapcar #'not (apply #'append vars)))))
(for (i 1 ,(length (apply #'append vars)) 2)
(multiple-value-bind
(succ k v) (next-entry)
(if succ
(progn
(setf (nth i current-band) k)
(setf (nth (+ 1 i) current-band) v))
(return-from o nil))))
current-band)
,#body))))
im getting "Evaluation aborted on #<UNDEFINED-FUNCTION NEXT-ENTRY {100229C693}>"
i dont understand why next-entry appears to be invisible to the macro i have created.
I've tried stripping down this to a small replicable example but i couldnt find a minimal scenario without the macro i created where next-entry would be invisible besides this scenario no matter what I tried, i've always managed to find a way to call next-entry in my other examples so im stumped as to why i cannot get it working here
I've tested the for macro ive created and it seems to generally work in most cases but for some reason it cannot see this next-entry variable. How do i make it visible?
In your code there are multiple places where the macro generates bindings in a way that is subject to variable capture (pdf).
(defmacro for-each-hashtable-band (body vars on &optional counter name)
`(block o ;; VARIABLE CAPTURE
(with-hash-table-iterator (next-entry ,on) ;; VARIABLE CAPTURE
(destructuring-bind ,(apply #'append vars)
(let ((current-band ;;; VARIABLE CAPTURE
(list ,#(mapcar #'not (apply #'append vars)))))
(for
(i ;;; VARIABLE CAPTURE
1 ,(length (apply #'append vars)) 2)
(multiple-value-bind (succ k v) ;;; VARIABLE CAPTURE
,(next-entry) ;;; WRONG EVALUATION TIME
(if succ
(progn
(setf (nth i current-band) k)
(setf (nth (+ 1 i) current-band) v))
(return-from o nil))))
current-band)
,#body))))
A simplified example of such a capture is:
`(let ((x 0)) ,#body)
Here above, the x variable is introduced, but if the code is expanded in a context where xis already bound, then body will not be able to reference that former x binding and will always see x bound to zero (you generally don't want this behavior).
Write a function instead
Instead of writing a big macro for this, let's first try understanding what you want to achieve and write instead a higher-order function, ie. a function that calls user-provided functions.
If I understand correctly, your function iterates over a hash-table by bands of entries. I assume vars holds a list of (key value) pairs of symbols, for example ((k1 v1) (k2 v2)). Then, body works on all the key/value pairs in the band.
In the following code, the function map-each-hashtable-band accepts a function, a hash-table, and instead of vars it accepts a size, the width of the band (the number of pairs).
Notice how in your code, you only have one loop, which builds a band using the hash-table iterator. But then, since the macro is named for-each-hashtable-band, I assume you also want to loop over all the bands. The macro with-hash-table-iterator provides an iterator but does not loop itself. That's why here I have two loops.
(defun map-each-hashtable-band (function hash-table band-size)
(with-hash-table-iterator (next-entry hash-table)
(loop :named outer-loop :do
(loop
:with key and value and next-p
:repeat band-size
:do (multiple-value-setq (next-p key value) (next-entry))
:while next-p
:collect key into current-band
:collect value into current-band
:finally (progn
(when current-band
(apply function current-band))
(unless next-p
(return-from outer-loop)))))))
For example:
(map-each-hashtable-band (lambda (&rest band) (print `(:band ,band)))
(alexandria:plist-hash-table
'(:a 0 :b 1 :c 2 :d 3 :e 4 :f 5 :g 6))
2)
NB. Iterating over a hash-table happens in an arbitrary order, there is no guarantee that you'll see the entries in any particular kind of order, this is implementation-dependant.
With my current version of SBCL this prints the following:
(:BAND (:A 0 :B 1))
(:BAND (:C 2 :D 3))
(:BAND (:E 4 :F 5))
(:BAND (:G 6))
Wrap the function in a macro
The previous function might not be exactly the behavior you want, so you need to adapt to your needs, but once it does what you want, you can wrap a macro around it.
(defmacro for-each-hashtable-band (vars hash-table &body body)
`(map-each-hashtable-band (lambda ,(apply #'append vars) ,#body)
,hash-table
,(length vars)))
For example:
(let ((test (alexandria:plist-hash-table '(:a 0 :b 1 :c 2 :d 3 :e 4 :f 5))))
(for-each-hashtable-band ((k1 v1) (k2 v2)) test
(format t "~a -> ~a && ~a -> ~a ~%" k1 v1 k2 v2)))
This prints:
A -> 0 && B -> 1
C -> 2 && D -> 3
E -> 4 && F -> 5
Macro-only solution, for completeness
If you want to have only one, single macro, you can start by inlining the body of the above function in the macro, you don't need to use apply anymore, but instead you need to establish bindings around the body, using destructuring-bind as you did. A first draft would be to simply as follows, but notice that this is not a proper solution:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
`(with-hash-table-iterator (next-entry ,hash-table)
(loop :named outer-loop :do
(loop
:with key and value and next-p
:repeat ,band-size
:do (multiple-value-setq (next-p key value) (next-entry))
:while next-p
:collect key into current-band
:collect value into current-band
:finally (progn
(when current-band
(destructuring-bind ,(apply #'append vars) current-band
,#body))
(unless next-p
(return-from outer-loop))))))))
In order to be free of variable capture problems with macros, each temporary variable you introduce must be named after a symbol that cannot exist in any context you expand your code. So instead we first unquote all the variables, making the macro definition fail to compile:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
`(with-hash-table-iterator (,next-entry ,hash-table)
(loop :named ,outer-loop :do
(loop
:with ,key and ,value and ,next-p
:repeat ,band-size
:do (multiple-value-setq (,next-p ,key ,value) (,next-entry))
:while ,next-p
:collect ,key into ,current-band
:collect ,value into ,current-band
:finally (progn
(when ,current-band
(destructuring-bind ,(apply #'append vars) ,current-band
,#body))
(unless ,next-p
(return-from ,outer-loop))))))))
When compiling the macro, the macro is supposed to inject symbols into the code, but here we have a compilation error that says undefined variables:
;; undefined variables: CURRENT-BAND KEY NEXT-ENTRY NEXT-P OUTER-LOOP VALUE
So now, those variables should be fresh symbols:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
(let ((current-band (gensym))
(key (gensym))
(next-entry (gensym))
(next-p (gensym))
(outer-loop (gensym))
(value (gensym)))
`(with-hash-table-iterator (,next-entry ,hash-table)
(loop :named ,outer-loop :do
(loop
:with ,key and ,value and ,next-p
:repeat ,band-size
:do (multiple-value-setq (,next-p ,key ,value) (,next-entry))
:while ,next-p
:collect ,key into ,current-band
:collect ,value into ,current-band
:finally (progn
(when ,current-band
(destructuring-bind ,(apply #'append vars) ,current-band
,#body))
(unless ,next-p
(return-from ,outer-loop)))))))))
This above is a bit verbose, but you could simplify that.
Here is what the previous for-each-hashtable-band example expands into with this new macro:
(with-hash-table-iterator (#:g1576 test)
(loop :named #:g1578
:do (loop :with #:g1575
and #:g1579
and #:g1577
:repeat 2
:do (multiple-value-setq (#:g1577 #:g1575 #:g1579) (#:g1576))
:while #:g1577
:collect #:g1575 into #:g1574
:collect #:g1579 into #:g1574
:finally (progn
(when #:g1574
(destructuring-bind
(k1 v1 k2 v2)
#:g1574
(format t "~a -> ~a && ~a -> ~a ~%" k1 v1 k2
v2)))
(unless #:g1577 (return-from #:g1578))))))
Each time you expand it, the #:gXXXX variables are different, and cannot possibly shadow existing bindings, so for example, the body can use variables named like current-band or value without breaking the expanded code.

Implementing a dictionary in common lisp

I am trying to implement a dictionary using lists in Common Lisp. The program is supposed to take a list of words and create a word histogram with frequency of each unique word.
This is the program:
(defparameter *histo* '())
(defun scanList (list)
(loop for word in list
do (if (assoc word histo)
((setf pair (assoc word histo))
(remove pair histo)
(setf f (+ 1 (second pair)))
(setf pair ((car pair) f))
(append histo pair))
((setf pair (word '1)) (append histo pair)))))
The error I get is: (SETF PAIR (ASSOC WORD *HISTO*)) should be a lambda expression.
Where is the syntax or semantic error exactly ?
(defun scanList (list the fox jumped over the other fox))
(princ *histo*)
Use hash-table for creating the dictionary and then transform to an association-list (alist) to sort it by key or value.
(defun build-histo (l)
(let ((dict (make-hash-table :test 'equal)))
(loop for word in l
do (incf (gethash word dict))
finally (return dict))))
;; which was simplification (by #Renzo) of
;; (defun build-histo (l)
;; (let ((dict (make-hash-table :test 'equal)))
;; (loop for word in l
;; for count = (1+ (gethash word dict 0))
;; do (setf (gethash word dict) count)
;; finally (return dict))))
(defparameter *histo* (build-histo '("a" "b" "c" "a" "a" "b" "b" "b")))
(defun hash-table-to-alist (ht)
(maphash #'(lambda (k v) (cons k v)) ht))
;; which is the same like:
;; (defun hash-table-to-alist (ht)
;; (loop for k being each hash-key of ht
;; for v = (gethash k ht)
;; collect (cons k v)))
;; sort the alist ascending by value
(sort (hash-table-to-alist *histo*) #'< :key #'cdr)
;; => (("c" . 1) ("a" . 3) ("b" . 4))
;; sort the alist descending by value
(sort (hash-table-to-alist *histo*) #'> :key #'cdr)
;; => (("b" . 4) ("a" . 3) ("c" . 1))
;; sort the alist ascending by key
(sort (hash-table-to-alist *histo*) #'string< :key #'car)
;; => (("a" . 3) ("b" . 4) ("c" . 1))
;; sort the alist descending by key
(sort (hash-table-to-alist *histo*) #'string> :eky #'car)
;; => (("c" . 1) ("b" . 4) ("a" . 3))
The posted code has a whole lot of problems. The reported error is caused by superfluous parentheses. Parentheses can't be added arbitrarily to expressions in Lisps without causing problems. In this case, these are the offending expressions:
((setf pair (assoc word histo))
(remove pair histo)
(setf f (+ 1 (second pair)))
(setf pair ((car pair) f)
(append histo pair))
((setf pair (word '1)) (append histo pair))
In both of these expressions, the results of the calls to setf are placed in the function position of a list, so the code attempts to call that result as if it is a function, leading to the error.
There are other issues. It looks like OP code is trying to pack expressions into the arms of an if form; this is probably the origin of the extra parentheses noted above. But, if forms can only take a single expression in each arm. You can wrap multiple expressions in a progn form, or use a cond instead (which does allow multiple expressions in each arm). There are some typos: *histo* is mistyped as histo in most of the code; f and pair are not defined anyplace; (setf pair (word '1)) quotes the 1 unnecessarily (which will work, but is semantically wrong).
Altogether, the code looks rather convoluted. This can be made much simpler, still following the same basic idea:
(defparameter *histo* '())
(defun build-histogram (words)
(loop :for word :in words
:if (assoc word *histo*)
:do (incf (cdr (assoc word *histo*)))
:else
:do (push (cons word 1) *histo*)))
This code is almost self-explanatory. If a word has already been added to *histo*, increment its counter. Otherwise add a new entry with the counter initialized to 1. This code isn't ideal, since it uses a global variable to store the frequency counts. A better solution would construct a new list of frequency counts and return that:
(defun build-histogram (words)
(let ((hist '()))
(loop :for word :in words
:if (assoc word hist)
:do (incf (cdr (assoc word hist)))
:else
:do (push (cons word 1) hist))
hist))
Of course, there are all kinds of other ways you might go about solving this.

Brainf**k implemented in Common Lisp

I tried implementing Brainf**k in Common Lisp, SBCL. I have encountered some problems.
(defparameter *tape* (make-array '(1) :adjustable t))
(defparameter *pointer* 0)
(defparameter *tape-size* 1)
(defparameter *output* (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))
(defun move-pointer-right (a b)
(declare (ignore a))
(declare (ignore b))
'(progn
(incf *tape-size*)
(adjust-array *tape* (list *tape-size*))
(incf *pointer*)))
(defun move-pointer-left (a b)
(declare (ignore a))
(declare (ignore b))
'(progn (decf *pointer*)))
(defun increment-byte (a b)
(declare (ignore a))
(declare (ignore b))
'(incf (aref *tape* *pointer*)))
(defun decrement-byte (a b)
(declare (ignore a))
(declare (ignore b))
'(decf (aref *tape* *pointer*)))
(defun start-loop (stream ch)
(declare (ignore ch))
(let ((loop-body (read-delimited-list #\] stream t)))
`(loop :until (zerop (aref *tape* *pointer*))
:do ,#loop-body)))
(defun print-one-char (a b)
(declare (ignore a))
(declare (ignore b))
'(with-output-to-string (s *output*) (write-char (code-char (aref *tape* *pointer*)) s)))
(defun read-one-char (a b)
(declare (ignore a))
(declare (ignore b))
'(setf (aref *tape* *pointer*) (char-code (read-char *standard-input*))))
(defun flush-output (a b)
(declare (ignore a))
(declare (ignore b))
'(progn *output*))
(defun reset-me (a b)
(declare (ignore a))
(declare (ignore b))
'(progn
(setf *output* (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))
(adjust-array *tape* '(1))
(setf (aref *tape* 0) 0)
(setf *pointer* 0)))
(set-macro-character #\< #'move-pointer-left)
(set-macro-character #\> #'move-pointer-right)
(set-macro-character #\+ #'increment-byte)
(set-macro-character #\[ #'start-loop)
(set-macro-character #\= #'flush-output)
(set-macro-character #\. #'print-one-char)
(set-macro-character #\, #'read-one-char)
(set-macro-character #\! #'reset-me)
(set-macro-character #\- #'decrement-byte)
input doesn't work
I am not sure whether nested loops would work because "[" reads to "]" and if you try "[/commands[/more]/dubious]" I don't how /dubious could be loaded with this methods.
I tried "++[->+>+<<]". As far as I know array should have: "0 2 2" but I got "0 2 0" instead. I conclude something is deeply wrong.
I am getting a lot of warnings from SBCL - it would be better to not have them:/
Is there a quick way to output all generated code (returned from functions such as "move-pointer-right") to file?
output is saved in one string to be printed at "=" command. I did it, because other operations were printing a lot of useless things to standard output. It is not a big problem for me - it seems easy to imagine just printing to file, instead of this workaround.
I am sorry for possible mistakes in my English.
Edit: I edited code (again - thank you for help, Sylwester). Everything but input seems to work.
As for input: I used read-char, but it doesn't work the way I want it. For example ,D inputs "D". I would like to redo it so it stops evaluation at each , and waits for user input.
Question: Is there an alternative to progn that does not return values (I want to just evaluate but not return)? For example (what-i-look-for (setf a 1) 1 2) sets a to 1 but does not return 2.
Without knowing too much about how you think its supposed to work you need to define tape, pointer and output as global variables, preferrably with *earmuffs* so that you can see they are globals.
(defparameter *tape* (make-array '(1) :adjustable t))
Then I noticed > extends the *tape* with a default element nil. Thus for every > you do you should set it to 0 if it's not true (every value is true except nil) It also seem to think that pointer is always at the end of the tape. When doing >>>++++<<< the element with 4 in it is long gone.
loop-body is a global variable. You should have used let here to not clobber package level variables. You use loopwrong. See examples in Loop for black belts. Eg.
(defun start-loop (stream ch)
(declare (ignore ch))
(let ((loop-body (read-delimited-list #\] stream t)))
`(loop :until (zerop (aref *tape* *pointer*))
:do ,#loop-body)))
Notice the declare there that tells Common Lisp to ignore ch not being used. The nesting is done automatically since read-deliited-list calls start-loop at a new [.
print-one-char doesn't add the char based on the ascii value but adds it as a number. Also usually it's common to print right away in BF so print-char might be better. You can print to a string input stream if you want to continue keeping it in memory until you press =.
read reads lisp data. Thus you would need to give it #\a instead of an a. Use read-char instead.
I guess you have enough to tacke at this point. Doing it with macros and reader-macros looked cool, but it is difficult to debug and extending since after the reader macros are added you have problems with code consisting those characters. Making one function for each operation except [ would simplify testing since you can test that and the macro would just expand to calling it.
(defun move-pointer-left ()
(assert (> *pointer* 0) (*pointer*) "Tape pointer out of bounds: ~a" *pointer*)
(decf *pointer*))
(set-macro-character #\< (constantly '(move-pointer-left)))

Common lisp hashtable

Task is to read N string like "name phone" and store in. Then find stored data with requests like "name".
My code stores names and numbers in hashtable, but after it doesn't find any values. Stored values checks with maphash (it shows all pairs key-value).
Function split-by-one-space is just utility.
(defparameter data (make-hash-table))
(defun split-by-one-space (string) ; to split string: "aaa bbb" -> (aaa bbb)
(loop for i = 0 then (1+ j)
as j = (position #\Space string :start i)
collect (subseq string i j)
while j))
(dotimes (i (read)) ; input data
(let* ((inp (read-line))
(raw (split-by-one-space inp))
(name (string (car raw)))
(phone (cadr raw)))
(format t "Adding: ~W ~W~%" name phone) ; debug
(setf (gethash name data) phone)))
(maphash #'(lambda (k v) (format t "~a => ~a~%" k v)) data) ; this show all stored data
(loop for line = (read-line *standard-input* nil :eof)
until (or (eq line :eof) (eq line nil))
do
(let ((key (gethash line data))) ; it cannot find anything. Why?
(format t "Searching: ~W~%" line) ; debug
(if (null key)
(format t "Not found~%")
(format t "~A=~A~%" (car key) (cdr key)))))
Sample input:
3
sam 99912222
tom 11122222
harry 12299933
sam
edward
harry
Unless you specify a test function, hash tables will use eql to determine "is this key identical to that key".
(defvar *s1* "a string")
(defvar *s2* "a string")
(loop for pred in '(eq eql equal equalp)
do (format t "Using ~a, the result is ~a~%"
pred (funcall pred *s1* *s2*)))
This generates the output:
Using EQ, the result is NIL
Using EQL, the result is NIL
Using EQUAL, the result is T
Using EQUALP, the result is T
In this case, the main difference between equal and equalp is that the latter is case-insensitive, while the former is not. To use another test function, use the :test keyword and one of the found "standard" test functions. If you don't need case-insensitive matches, you would simply create your hash table like this: (make-hash-table :test #'equal).

In common lisp how can I format a floating point and specify grouping, group char and decimal separator char

Let's say I have the floating point number 1234.9
I want to format it as 1.234,90
Is there a format directive combination for that? ~D ,which can handle the grouping and the group char, handles only integers. ~F doesn't handle grouping at all. And none as far as I know can change the decimal point from . to ,
The only solution I see is to use ~D for the integer part digit grouping and concatenate it with , and the decimal part. Any better ideas?
You can define a function to be called with tilde-slash, which most of the other answers have already done, but in order to get output similar to ~F, but with comma chars injected, and with the decimal point replaced, I think it's best to call get the output produced by ~F, and then modify it and write it to the string. Here's a way to do that, using a utility inject-comma that adds a comma character at specified intervals to a string. Here's the directive function:
(defun print-float (stream arg colonp atp
&optional
(point-char #\.)
(comma-char #\,)
(comma-interval 3))
"A function for printing floating point numbers, with an interface
suitable for use with the tilde-slash FORMAT directive. The full form
is
~point-char,comma-char,comma-interval/print-float/
The point-char is used in place of the decimal point, and defaults to
#\\. If : is specified, then the whole part of the number will be
grouped in the same manner as ~D, using COMMA-CHAR and COMMA-INTERVAL.
If # is specified, then the sign is always printed."
(let* ((sign (if (minusp arg) "-" (if (and atp (plusp arg)) "+" "")))
(output (format nil "~F" arg))
(point (position #\. output :test 'char=))
(whole (subseq output (if (minusp arg) 1 0) point))
(fractional (subseq output (1+ point))))
(when colonp
(setf whole (inject-comma whole comma-char comma-interval)))
(format stream "~A~A~C~A"
sign whole point-char fractional)))
Here are some examples:
(progn
;; with # (for sign) and : (for grouping)
(format t "~','.2#:/print-float/ ~%" 12345.6789) ;=> +1.23.45,679
;; with no # (no sign) and : (for grouping)
(format t "~'.'_3:/print-float/ ~%" 12345.678) ;=> 12_345.678
;; no # (but sign, since negative) and : (for grouping)
(format t "~'.'_3:/print-float/ ~%" -12345.678) ;=> -12_345.678
;; no # (no sign) and no : (no grouping)
(format t "~'.'_3#/print-float/ ~%" 12345.678)) ;=> +12345.678 (no :)
Here are the examples from coredump-'s answer, which actually helped me catch a bug with negative numbers:
CL-USER> (loop for i in '(1034.34 -223.12 -10.0 10.0 14 324 1020231)
do (format t "~','.:/print-float/~%" i))
1.034,34
-223,12
-10,0
10,0
14,0
324,0
1.020.231,0
NIL
Here's inject-comma, with some examples:
(defun inject-comma (string comma-char comma-interval)
(let* ((len (length string))
(offset (mod len comma-interval)))
(with-output-to-string (out)
(write-string string out :start 0 :end offset)
(do ((i offset (+ i comma-interval)))
((>= i len))
(unless (zerop i)
(write-char comma-char out))
(write-string string out :start i :end (+ i comma-interval))))))
(inject-comma "1234567" #\, 3)
;;=> "1,234,567"
(inject-comma "1234567" #\. 2)
;;=> "1.23.45.67"
As the comment of jkiiski suggests, you could use the ~/func/ directive.
This is just an example, you can elaborate more with the function:
CL-USER> (defun q(stream arg &rest args)
(declare (ignore args))
(format stream
"~,,'.,:D,~a"
(truncate arg)
(let ((float-string (format nil "~f" arg)))
(subseq float-string (1+ (position #\. float-string))))))
Q
CL-USER> (format t "~/q/~%" 1024.36)
1.024,36
NIL
CL-USER> (format t "~/q/~%" -1024.36)
-1.024,36
NIL
Edited
The first version had round, which is wrong, truncate is the right operator to use.
If you don't mind splitting integer and fractional part, you can do the following:
(multiple-value-bind (int rest) (floor 1234.56)
(let ((rest (round (* rest 1000))))
(format t "~,,'.,:D,~D~%" int rest)))
1.234,560
The multiplication before rounding tells how many digits after comma you would like to print. Not sure if this approach lands itself nicely into automatic control of precision printing, i.e. 1.5 printed as "1,5" and not as "1,500".
Other answers currently use round, which is probably not the intended behavior when rounding up (positive numbers) or down (negative numbers). Here is another approach for a ~/custom/ directive, derived mostly from Renzo's answer.
(defun custom (stream number &rest args)
(declare (ignore args))
(multiple-value-bind (integer decimal) (truncate number)
(format stream "~,,'.,:D~#[,~a~]"
integer
(unless (zerop decimal)
(let ((decimal-string (princ-to-string (abs decimal))))
(subseq decimal-string (1+ (position #\. decimal-string))))))))
TESTS
(loop for i in '(1034.34 -223.12 -10.0 10.0 14 324 1020231)
collect (custom nil i))
=> ("1.034,33996582" "-223,11999512" "-10" "10" "14" "324" "1.020.231")
I've come to this little solution for positive numbers.
(defun comma-point (stream arg &rest args)
(declare (ignore args))
(multiple-value-bind (i r) (truncate arg)
(format stream "~,,',,:D.~2,'0D" i (truncate (* 100 r)))))
;; ^ ^
;; | `Decimal point
;; `Thousands separator
(defun point-comma (stream arg &rest args)
(declare (ignore args))
(multiple-value-bind (i r) (truncate arg)
(format stream "~,,'.,:D,~2,'0D" i (truncate (* 100 r)))))
(defun space-comma (stream arg &rest args)
(declare (ignore args))
(multiple-value-bind (i r) (truncate arg)
(format stream "~,,' ,:D,~2,'0D" i (truncate (* 100 r)))))
The testing numbers:
(dolist (value '(1034.34 -223.12 -10.0 10.0 14 324 1020231.099))
(format t "~16#A" (format nil "~/comma-point/" value))
(format t "~16#A" (format nil "~/point-comma/" value))
(format t "~16#A~%" (format nil "~/space-comma/" value)))
;; 1,034.33 1.034,33 1 034,33
;; -223.-11 -223,-11 -223,-11
;; -10.00 -10,00 -10,00
;; 10.00 10,00 10,00
;; 14.00 14,00 14,00
;; 324.00 324,00 324,00
;; 1,020,231.12 1.020.231,12 1 020 231,12
The second test number shows that does not work for negative numbers (-223.11 => -223,-11). Also, using truncate (or other similar functions) implies that a loss of accuracy appears, as can be seen in the last test number (1020231.099 => 1.020.231,12).

Resources