Read in data from the user in a loop - common-lisp

For a little game I am working on, I want to read in the names of the players. I have two solutions so far which I find both a bit cumbersome. Version 1 forces the user to additionally state that he/she wants to add more players:
(defun read-player ()
(loop :while (y-or-n-p "Add another player?")
:do (format t "~& Name of player #~D: " (1+ (length players)))
:collect (read-line) :into players
:finally (print players)))
Version 2 needs a duplicate of the format expression:
(defun read-player2 ()
(let ((players '()))
(format t "~& Name of player #~D: " (1+ (length players)))
(loop :for player = (read-line)
:until (string= player "")
:collect player :into players
:do (format t "~& Name of player #~D: " (1+ (length players)))
:finally (print players))))
Is there a synthesis of my two approaches? Not bothering the user with additional questions and not repeating code?

How about using progn when reading the player?
(defun read-players ()
(loop :for player-count :upfrom 1
:for player =
(progn
(format t "~& Name of player #~D (RET to stop): " player-count)
(finish-output)
(read-line))
:while (plusp (length player))
:collect player))
> (read-players)
Name of player #1 (RET to stop): r
Name of player #2 (RET to stop): g
Name of player #3 (RET to stop):
==> ("r" "g")
PS. It is relatively common to add a function like
(defun ask-user (format-string &rest format-arguments)
(fresh-line)
(apply #'format t format-string format-arguments)
(finish-output)
(read-line))
or, if you are fond of format magic,
(defun ask-user (format-string &rest format-arguments)
(format t "~&~?: " format-string format-arguments)
(finish-output)
(read-line))
This would make your read-players even more readable:
(defun read-players ()
(loop :for player-count :upfrom 1
:for player = (ask-user "Name of player #~D (RET to stop)" player-count)
:while (plusp (length player))
:collect player))

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.

Why when I convert a string to a symbol using intern is the accesror function for structures returning an error?

I am by most standards a novice lisp programmer, however, I don't feel what I am trying to do is particularly complex and I do not understand why it is not working.
I am trying to create a database of events that occur throughout time and are connected based on how they appear in relation to one another. This concept is highly experimental and not what I'm looking for feedback on.
The idea is to generate a random name for the event (which are referred to as symbols in the program, bad style, I know), generate a random number of appearances for the event (which have a start time, a duration, and a period of time that elapses until the event occurs again). Then once I have created a random number of event types, and a random number of appearances for each, I'd like to organize them in a list in chronological order, but I am not getting very far because the name I am creating is generating a type error in sym-aprs-h, in the sym-appearances accessor function. It is trying to tell me that it is not of expected type sym, but when I run tests such as calling type-of on ran-sym-name it returns symbol. So I really have no idea what is going on.
(defun initialize ()
(defvar *alphabet* '#(a b c d e f g h i j k l m n o p q r s t u v w x y z))
(defvar *symbol-names* nil)
(defvar *moment-chain* nil))
(defun ran-let ()
(Coerce (aref *alphabet* (random 26)) 'character))
(defun ran-sym-name ()
(intern (coerce (list (ran-let) (ran-let) (ran-let) (ran-let) (ran-let) (ran-let)) 'string)))
(defstruct sym
(name nil)
(appearances nil)
(connections nil))
(defun ran-sym-gen ()
(let ((x (ran-sym-name)))
(cond ((member x *Symbol-names*) (ran-sym-gen))
(t (push x *Symbol-names*)(make-sym :name x)(sym-aprs x)))))
(defun sym-aprs-h (s tm n)
(let ((dr (+ 1 (random 7200))))
(cond ((= n 0) nil)
(t (push (list tm dr nil) (sym-appearances s)) (push (list tm dr s nil) *moment-chain*) (sym-aprs-h s (+ tm dr (random 14400)) (- n 1))))))
(defun sym-aprs (s)
(sym-aprs-h s (get-universal-time) (+ 1 (random 101))))
(defun mchain-org ()
(sort *moment-chain* #'< :key #'car))
(defun mchain-con (n)
(cond ((= 0 n) nil)
(t (ran-sym-gen) (mchain-con (- n 1)))))
As I said I'm new to the language and teaching myself by taking on a smidge more than I can handle. Any constructive criticism would be appreciated, however, I'm primarily interested in getting sym-appearances to not generate a type error.
(defun initialize ()
(defvar *alphabet* '#(a b c d e f g h i j k l m n o p q r s t u v w x y z))
(defvar *symbol-names* nil)
(defvar *moment-chain* nil))
DEFVAR does not belong inside a DEFUN. DEFVAR is a toplevel macro.
(defun ran-let ()
(Coerce (aref *alphabet* (random 26)) 'character))
Coerce over and over.
(defun ran-sym-name ()
(intern (coerce (list (ran-let) (ran-let) (ran-let) (ran-let) (ran-let) (ran-let))
'string)))
Just pick characters from a string and append them.
(defstruct sym
(name nil)
(appearances nil)
(connections nil))
(defun ran-sym-gen ()
(let ((x (ran-sym-name)))
(cond ((member x *Symbol-names*) (ran-sym-gen))
(t (push x *Symbol-names*)
(make-sym :name x)
(sym-aprs x)))))
The result of (make-sym :name x) disappears in the Lisp nirvana. You pass the symbol to sym-aprs is that really what you want?
(defun sym-aprs-h (s tm n)
(let ((dr (+ 1 (random 7200))))
(cond ((= n 0) nil)
(t (push (list tm dr nil) (sym-appearances s))
(push (list tm dr s nil) *moment-chain*)
(sym-aprs-h s (+ tm dr (random 14400)) (- n 1))))))
(defun sym-aprs (s)
(sym-aprs-h s (get-universal-time) (+ 1 (random 101))))
(defun mchain-org ()
(sort *moment-chain* #'< :key #'car))
(defun mchain-con (n)
(cond ((= 0 n) nil)
(t (ran-sym-gen) (mchain-con (- n 1)))))
Why not use DOTIMES or LOOP?
Style: you might want to check the types of s and other variables. It might also be useful to use speaking names and/or documentation.
If you look at the code in a week you won't be able to tell what it is supposed to do...
You also want to format the code differently. See my version.

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).

Joining a series of paths components in common lisp

How do I join a series of path components in common lisp?
In python, I can do,
`os.path.join("/home/", username, "dira", "dirb", "dirc");`
What would be the equivalent in common lisp?
Of course I can write my own function, but I suspect I should be able to use something built-in.
If you insist on using strings to represent pathnames, then there seems to be no built-in solution except rolling your own.
(defun join-strings (list &key (separator "/") (force-leading nil))
(let* ((length (length list))
(separator-size (length separator))
(text-size (reduce #'+ (mapcar #'length list) :initial-value 0))
(size (+ text-size (* separator-size (if force-leading length (1- length)))))
(buffer (make-string size)))
(flet ((copy-to (position string)
(loop
:with wp := position
:for char :across string
:do (setf (char buffer (prog1 wp (incf wp))) char)
:finally (return wp))))
(loop
:with wp := 0
:for string :in list
:do (when (or force-leading (plusp wp)) (setf wp (copy-to wp separator)))
(setf wp (copy-to wp string)))
buffer)))
(join-strings '("home" "kurt" "source" "file.txt") :force-leading t)
==> "/home/kurt/source/file.txt"
However, if you can use pathnames, then you could, for example, do:
(merge-pathnames #P"subdir1/subdir2/file.type" #P"/usr/share/my-app")
==> #P"/usr/share/my-app/subdir1/subdir2/file.type"
The pathname API also provides functions to manipulate pathnames symbolically, extract the components of a pathname, etc.:
(pathname-directory #P"subdir1/subdir2/file.type")
==> '(:relative "subdir1" "subdir2")
(pathname-name #P"subdir1/subdir2/file.type")
==> "file"
(pathname-type #P"subdir1/subdir2/file.type")
==> "type"
(make-pathname :name "file" :type "type" :directory '(:relative "subdir1" "subdir2"))
==> #P"subdir1/subdir2/file.type"
In particular, the directory component of a pathname is represented as a list, and thus, you can use the full set of list handling functions to derive directory values from others:
(make-pathname :directory (append '(:absolute "usr" "share") '("more" "stuff"))
:name "packages" :type "lisp")
A simpler join-strings
(defun join-strings (lst sep)
(if
(atom lst)
lst
(reduce
(lambda (a b)
(concatenate 'string a sep b))
(cdr lst)
:initial-value (car lst))))

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

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)))

Resources