I am trying to get the first row under the column with the title "Name" so for example for https://en.wikipedia.org/wiki/List_of_the_heaviest_people I want to return the name "Jon Brower Minnoch". My code so far is as follows, but I think there must be a more general way of getting the name:
(defun find-tag (tag doc)
(when (listp doc)
(when (string= (xmls:node-name doc) tag)
(return-from find-tag doc))
(loop for child in (xmls:node-children doc)
for find = (find-tag tag child)
when find do (return-from find-tag find)))
nil)
(defun parse-list-website (url)
(second (second (second (third (find-tag "td" (html5-parser:parse-html5 (drakma:http-request url) :dom :xmls)))))))
and then to call the function:
(parse-list-website "https://en.wikipedia.org/wiki/List_of_the_heaviest_people")
I am not very good with xmls and don't know how to get an get a td under a certain column header.
The elements in the document returned by html5-parser:parse-html5 are in the form:
("name" (attribute-alist) &rest children)
You could access the parts with the standard list manipulation functions, but xmls also provides functions node-name, node-attrs and node-children to access the three parts. It's a little bit clearer to use those. Edit: there are also functions xmlrep-attrib-value, to get the value of an attribute and xmlrep-tagmatch to match the tag name. The children are either plain strings, or elements in the same format.
So for example, a html document with a 2x2 table would look like this:
(defparameter *doc*
'("html" ()
("head" ()
("title" ()
"Some title"))
("body" ()
("table" (("class" "some-class"))
("tr" (("class" "odd"))
("td" () "Some string")
("td" () "Another string"))
("tr" (("class" "even"))
("td" () "Third string")
("td" () "Fourth string"))))))
In order to traverse the dom-tree, lets define a recursive depth-first search like this (note that the if-let depends on the alexandria library (either import it, or change it to alexandria:if-let)):
(defun find-tag (predicate doc &optional path)
(when (funcall predicate doc path)
(return-from find-tag doc))
(when (listp doc)
(let ((path (cons doc path)))
(dolist (child (xmls:node-children doc))
(if-let ((find (find-tag predicate child path)))
(return-from find-tag find))))))
It's called with a predicate function and a document. The predicate function gets called with two arguments; the element being matched and a list of its ancestors. In order to find the first <td>, you could do this:
(find-tag (lambda (el path)
(declare (ignore path))
(and (listp el)
(xmls:xmlrep-tagmatch "td" el)))
*doc*)
; => ("td" NIL "Some string")
Or to find the first <td> in the even row:
(find-tag (lambda (el path)
(and (listp el)
(xmls:xmlrep-tagmatch "td" el)
(string= (xmls:xmlrep-attrib-value "class" (first path))
"even")))
*doc*)
; => ("td" NIL "Third string")
Getting the second <td> on the even row would require something like this:
(let ((matches 0))
(find-tag (lambda (el path)
(when (and (listp el)
(xmls:xmlrep-tagmatch "td" el)
(string= (xmls:xmlrep-attrib-value "class" (first path))
"even"))
(incf matches))
(= matches 2))
*doc*))
You could define a helper function to find the nth tag:
(defun find-nth-tag (n tag doc)
(let ((matches 0))
(find-tag (lambda (el path)
(declare (ignore path))
(when (and (listp el)
(xmls:xmlrep-tagmatch tag el))
(incf matches))
(= matches n))
doc)))
(find-nth-tag 2 "td" *doc*) ; => ("td" NIL "Another string")
(find-nth-tag 4 "td" *doc*) ; => ("td" NIL "Fourth string")
You might want to have a simple helper to get the text of a node:
(defun node-text (el)
(if (listp el)
(first (xmls:node-children el))
el))
You could define similiar helpers to do whatever you need to do in your application. Using these, the example you gave would look like this:
(defparameter *doc*
(html5-parser:parse-html5
(drakma:http-request "https://en.wikipedia.org/wiki/List_of_the_heaviest_people")
:dom :xmls))
(node-text (find-nth-tag 1 "a" (find-nth-tag 1 "td" *doc*)))
; => "Jon Brower Minnoch"
Related
I am trying to do the following: separate a function that gets values from some user input from the function that uses it.
I have tried the following code for the proof of concept initially (that worked):
(defun initialiser (bindings)
(cl-loop for (var) in bindings do
(set var (read-from-minibuffer "Input value: "))))
That i have tested with:
(let ((name))
(initialiser '((name)))
(message "name is %S" name))
The idea was to pass bindings to the function that handles input in the form like ((name "Name") (address "Post address") (code "County code")) or something similar, and in there assign the input.
After testing above i have come up with the following macro to do things:
(defmacro initialise-and-execute (bindings initialiser &rest callback-actions)
(let ((unwrapped-bindings (map 'list (lambda (binding) (car binding)) bindings)))
`(let ,unwrapped-bindings
(,initialiser (quote ,bindings)
(lambda () ,#callback-actions)))))
However, in the "real" scenario the assignments must happen in callbacks, like:
(defun initialiser(bindings)
(cl-loop for (var) in bindings collect
(lambda () (set var (read-from-minibuffer "Input value: ")))
into callbacks
return callbacks))
This fails to work. Code i have used to test was:
(defvar callbacks nil)
(let ((name))
(setq callbacks (initialiser '((name)))))
(funcall (car callbacks))
Edit: changed the code the following way:
(defmacro initialise-and-execute (bindings initialiser &rest callback-actions)
(let ((unwrapped-bindings (map 'list (lambda (binding) (car binding)) bindings)))
`(lexical-let ,unwrapped-bindings
(,initialiser
(quote ,(map 'list
(lambda (binding) (list (cadr binding)
`(lambda (val) (setq ,(car binding) val))))
bindings))
(lambda () ,#callback-actions)))))
What it must do: generate number of lambdas that share the same lexical environment - one that uses captured variables and the rest that modify them.
However, what i get is, regrettably, something else. Symbols used in callback-actions do not resolve into the values set.
For completeness, here is how i tested it:
(defun init-values (bindings callback)
(loop for (desc setter) in bindings
for idx = 0 then (incf idx)
do (print (format "Setting %s" desc))
(funcall setter idx))
(funcall callback))
(initialise-and-execute
((name "Name")
(surname "Surname"))
init-values
(message "name is %S" name))
Here, lambdas were not generated in a loop and values in the context of a lexical binding were assigned with setq.
To set the function value, use fset, not set.
(defun initialiser(bindings)
(cl-loop for (var) in bindings collect
(lambda () (fset var (read-from-minibuffer "Input value: ")))
into callbacks
return callbacks))
There are possible issues:
in a LOOP the VAR is possibly assigned on each iteration, not bound (that's in Common Lisp). so your callbacks set all the same VAR value.
in a lexical bound Lisp (new in GNU Emacs Lisp) one can't set the variable values with SET
Examples:
ELISP> (mapcar #'funcall
(cl-loop for i in '(1 2 3 4)
collect (lambda () i)))
(4 4 4 4)
all closures have the same value of i
ELISP> (let ((a 'foobar))
(set 'a 42)
a)
foobar
SET had no effect on the local variable
In Common Lisp I might write something like:
(defun initializer (bindings)
(loop for (what setter) in bindings
for new-value = (progn
(format t "Enter ~a: " what)
(finish-output)
(read-line))
do (funcall setter new-value)))
(defmacro call-with-bindings (name-sym-list fn)
(let ((value-sym (gensym "v")))
`(,fn
(list ,#(loop for (name sym) in name-sym-list
collect `(list ,name ,`(lambda (,value-sym)
(setf ,sym ,value-sym))))))))
CL-USER > (let (name age)
(call-with-bindings (("name" name) ("age" age))
initializer)
(format t "name is ~S~%" name)
(values name age))
Enter name: Lara
Enter age: 42
name is "Lara"
"Lara"
"42"
Where we can look at the macro expansion:
CL-USER > (pprint (macroexpand-1
'(call-with-bindings (("name" name) ("age" age))
initializer)))
(INITIALIZER (LIST (LIST "name"
(LAMBDA (#:|v1669|)
(SETF NAME #:|v1669|)))
(LIST "age"
(LAMBDA (#:|v1669|)
(SETF AGE #:|v1669|)))))
After some experimenting, i have been able to do it. The key was realising that lexical-let apparently had some restrictions on how the lambda should be placed for them to have the same closure context. After i have managed to generate set of closures that referred to the same variables, the rest was easy.
Here is the final code:
(defmacro make-lamba-set (bindings &rest callback-actions)
"Make set of closures with shared context
BINDINGS are a list of form (SYMBOL NAME), where SYMBOL is not defined yet
CALLBACK-ACTIONS are forms that use symbols from bindings
Return created captures a as a list of forms:
(do-callback-actions (set-symbol NAME) ...)"
(let ((unwrapped-bindings (map 'list
(lambda (binding)
(car binding))
bindings)))
`(lexical-let ,unwrapped-bindings
(list (lambda () ,#callback-actions)
,#(map 'list
(lambda (binding)
`(list
(lambda (val)
(setq ,(car binding) val))
,(cadr binding)))
bindings)))))
(defmacro initialise-and-execute (bindings initialiser &rest callback-actions)
"BINGINGS have form of ((BINDING-SYMBOL PROMPT) ...)
INITIALISER somehow assigns values to all of BINDING-SYMBOL
then it calls CALLBACK-ACTIONS with values of BINDING-SYMBOL set"
`(let ((closure-parts (make-lamba-set ,bindings ,#callback-actions)))
(,initialiser (cdr closure-parts)
(car closure-parts))))
Here is how i tested it:
(defun init-values (bindings callback)
(loop for (setter desc) in bindings
for idx = 0 then (incf idx)
do (message "Setting %s" desc)
(funcall setter idx))
(funcall callback))
(initialise-and-execute ((name "Name")
(surname "Surname"))
init-values
(insert (format "Name is %S and surname is %S"
name
surname)))
That gave me expected output of:
Name is 0 and surname is 1
I want to write a function that will return a string formatted with alternative upcase/downcase in Common Lisp. For example, entering "stackoverflow" should return the string "StAcKoVeRfLoW". Here's my attempt, but it just returns a list of cons pairs. Am I on the right track?
(defun mockify (chars)
(let ((lst (coerce chars 'list)))
(if (equal lst nil) nil
(coerce (cons
(cons (char-upcase (car lst)) (char-downcase (cadr lst)))
(mockify (cddr lst)))
'string))))
CL-USER> (mockify "meow")
((#\M . #\e) (#\O . #\w))
Using MAP: we are creating a new string, moving over the original string and upcase/downcase based on an alternating boolean variable.
CL-USER 353 > (let ((string "stackoverflow")
(upcase t))
(map (type-of string)
(lambda (element)
(prog1 (if upcase
(char-upcase element)
(char-downcase element))
(setf upcase (not upcase))))
string))
"StAcKoVeRfLoW"
(defun mockify (chars)
(let ((lst (coerce chars 'list)))
(if (equal lst nil)
;; return nil
nil
;; return a string (coerce)
(coerce
;; a list whose elements are cons-cells, but ...
(cons (cons (char-upcase (car lst))
(char-downcase (cadr lst)))
;; ... the rest is computed by calling mockify,
;; which returns either an empty list or a string
(mockify (cddr lst)))
'string))))
The types of your expressions are confusing, and in fact your example leads to an error when using SBCL:
> (mockify "meow")
The value
(#\O . #\w)
is not of type
CHARACTER
when setting an element of (ARRAY CHARACTER)
[Condition of type TYPE-ERROR]
Also, you are going to have to handle corner cases in your code, because as is, it is possible that (cadr list), i.e. (second list), is called on a list that has only one element. Then, the result would be NIL and char-downcase would fail with an error.
Using only strings
I'd suggest writing a version of the function that does not use intermediate lists:
let R be the string-downcase of the whole string
then modify every other character of R by upcasing it
So for example, one way to do it (among others) would be:
(defun mockify (chars)
(let ((chars (string-downcase chars)))
(prog1 chars
(upcasify chars 0))))
(defun upcasify (string index)
(when (< index (length string))
(setf (char string index) (char-upcase (char string index)))
(upcasify string (+ index 2))))
Using only lists
If you prefer having a recursive function that processes lists, I'd rather define it in layers:
coerce string to list
process the list recursively
eventually, coerce the resulting list back to a string
This will avoid doing conversions from strings to lists at every step, and make the code simpler at each level.
(defun mockify (chars)
(coerce (mockify-list (coerce chars 'list)) 'string))
(defun mockify-list (chars)
...)
The list version is recursive and look like what you tried to do, but take care of corner cases.
There is more than one way to do it. Here is a loop based solution:
(let ((string "StackOverflow"))
(with-output-to-string (s)
(loop :for c :across string
:for up := t :then (not up)
:do (princ (if up
(char-upcase c)
(char-downcase c))
s))))
Fun thing - I actually wrote a similar thing some time ago.
https://github.com/phoe/string-pokemonize
I have a representation of a tree using lists.
For example:
(1 ((2 (3)) (3 (2)))) (2 ((1 (3)) (3 (1)))) (3 ((1 (2)) (2 (1)))))`
Now I need to traverse it level by level while maintaining the hierarchy tree. For instance:
Traversing root node (1)
Traversing depth 1 (1 2) (1 3) (2 1) (3 1) (3 1) (3 2)
Traversing depth 2 (1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)
I can't figure out how to do it in Lisp. Any help (even a pseudo code) is appreciated. I have thought of several approaches but none of them seems legit.
Breadth-first search using an agenda
The classic way to do a breadth-first search is by maintaining an agenda: a list of things to look at next. Then you simply peel objects off the start of the agenda, and add their children to the end of the agenda. A very simple-minded approach to such an agenda is a list of nodes: to add to the end of the list you then use append.
I can't understand your tree structure (please, when asking questions which need specification of a data structure or an algorithm give that specification: it is a waste of everyone's time to try to second-guess this) so I have made my own in terms of lists: a tree is a cons whose car is its value and whose cdr is a list of children. Here are functions to make and access such a tree structure, and a sample tree.
(defun tree-node-value (n)
(car n))
(defun tree-node-children (n)
(cdr n))
(defun make-tree-node (value &optional (children '()))
(cons value children))
(defparameter *sample-tree*
(make-tree-node
1
(list
(make-tree-node 2 (list (make-tree-node 3)))
(make-tree-node 4 (list (make-tree-node 5) (make-tree-node 6)))
(make-tree-node 7 (list (make-tree-node 8 (list (make-tree-node 9))))))))
Now I never have to worry about the explicit structure of trees again.
Now here is a function which uses an agenda which will search this tree for a given node value:
(defun search-tree/breadth-first (tree predicate)
;; search a tree, breadth first, until predicate matches on a node's
;; value. Return the node that matches.
(labels ((walk (agenda)
(if (null agenda)
;; we're done: nothing matched
(return-from search-tree/breadth-first nil)
(destructuring-bind (this . next) agenda
(if (funcall predicate (tree-node-value this))
;; found it, return the node
(return-from search-tree/breadth-first this)
;; missed, add our children to the agenda and
;; carry on
(walk (append next (tree-node-children this))))))))
(walk (list tree))))
For comparison here is a depth first search:
(defun search-tree/depth-first (tree predicate)
;; search a tree, depth first, until predicate matches on a node's
;; value
(labels ((walk (node)
(if (funcall predicate (tree-node-value node))
(return-from search-tree/depth-first node)
(dolist (child (tree-node-children node) nil)
(walk child)))))
(walk tree)))
You can now compare these implementations by having a predicate which prints its argument but always fails, thus causing a traversal of the whole tree:
> (search-tree/breadth-first *sample-tree*
(lambda (v)
(print v)
nil))
1
2
4
7
3
5
6
8
9
nil
> (search-tree/depth-first *sample-tree*
(lambda (v)
(print v)
nil))
1
2
3
4
5
6
7
8
9
nil
Appendix 1: a better agenda implementation
One problem with this naive agenda implementation is that we end up calling append all the time. A cleverer implementation allows items to be appended to the end efficiently. Here is such an implementation:
(defun make-empty-agenda ()
;; an agenda is a cons whose car is the list of items in the agenda
;; and whose cdr is the last cons in that list, or nil is the list
;; is empty. An empty agenda is therefore (nil . nil)
(cons nil nil))
(defun agenda-empty-p (agenda)
;; an agenda is empty if it has no entries in its list.
(null (car agenda)))
(defun agenda-next-item (agenda)
;; Return the next entry from the agenda, removing it
(when (agenda-empty-p agenda)
(error "empty agenda"))
(let ((item (pop (car agenda))))
(when (null (car agenda))
(setf (cdr agenda) nil))
item))
(defun agenda-add-item (agenda item)
;; add an item to the end of the agenda, returning it
(let ((item-holder (list item)))
(if (agenda-empty-p agenda)
(setf (car agenda) item-holder
(cdr agenda) item-holder)
(setf (cdr (cdr agenda)) item-holder
(cdr agenda) item-holder))
item))
Note that there is no way of copying one of these agendas provided.
Here is an explicitly iterative function which uses this 'clever' agenda:
(defun search-tree/breadth-first/iterative (tree predicate)
(loop with agenda = (make-empty-agenda)
initially (agenda-add-item agenda tree)
while (not (agenda-empty-p agenda))
for node = (agenda-next-item agenda)
when (funcall predicate (tree-node-value node))
do (return-from search-tree/breadth-first/iterative node)
else do (loop for c in (tree-node-children node)
do (agenda-add-item agenda c))
finally (return nil)))
Finally, any agenda-based search can easily be modified to be restartable: it simply needs to return the current agenda at the point it matched, and allow passing in of an agenda. Here is a variant of the above function which supports restarting searches:
(defun search-tree/breadth-first/iterative (tree predicate
&optional (agenda
(make-empty-agenda)))
;; search TREE using PREDICATE. if AGENDA is given and is not empty
;; instead restart using it (TREE is ignored in this case). Return
;; the node found, or nil, and the remaining agenda
(loop initially (unless (not (agenda-empty-p agenda))
(agenda-add-item agenda tree))
while (not (agenda-empty-p agenda))
for node = (agenda-next-item agenda)
when (funcall predicate (tree-node-value node))
do (return-from search-tree/breadth-first/iterative
(values node agenda))
else do (loop for c in (tree-node-children node)
do (agenda-add-item agenda c))
finally (return (values nil agenda))))
Appendix 2: general search with an agenda
It is in fact possible to further generalise the agenda-based approach to searching trees. In particular:
if the agenda is a queue (FIFO) then you get breadth-first search;
if the agenda is a stack (LIFO) then you get depth-first search.
The actual search implementation can be identical for these two cases, which is neat.
Below is some code which demonstrates this. This defines generic functions for tree access (with methods for cons-based trees) so nothing needs to care about that, and further defines a protocol for agendas with two concrete classes, queue and stack which have appropriate methods. The search function is then completely agnostic about whether it does depth-first or breadth-first search, and is restartable in either case.
This is a fairly substantial chunk of code: I'm leaving it here just in case it's useful to anyone.
;;;; Trees
;;;
(defgeneric tree-node-value (n)
(:documentation "The value of a tree node"))
(defgeneric tree-node-children (n)
(:documentation "The children of a tree"))
;;;; Consy trees
;;;
(defmethod tree-node-value ((n cons))
(car n))
(defmethod tree-node-children ((n cons))
(cdr n))
(defun make-cons-tree-node (value &optional (children '()))
;; consy trees: I could do some clever EQL method thing perhaps to
;; abstract this?
(cons value children))
(defun form->tree (form &key (node-maker #'make-cons-tree-node))
(labels ((walk-form (f)
(destructuring-bind (value . child-forms) f
(funcall node-maker
value
(mapcar #'walk-form child-forms)))))
(walk-form form)))
(defparameter *sample-tree*
(form->tree '(1 (2 (3))
(4 (5) (6))
(7 (8 (9))))))
;;;; Agendas
;;;
(defclass agenda ()
())
(defgeneric agenda-empty-p (agenda)
(:documentation "Return true if AGENDA is empty"))
(defgeneric agenda-next-item (agenda)
(:documentation "Return the next item from AGENDA.
If there is no next item, signal an error: there is a before method which does this.")
(:method :before ((agenda agenda))
(when (agenda-empty-p agenda)
(error "empty agenda"))))
(defmethod initialize-instance :after ((agenda agenda) &key
(item nil itemp)
(items (if itemp (list item) '()))
(ordered nil))
(agenda-add-items agenda items :ordered ordered))
(defgeneric agenda-add-item (agenda item)
(:documentation "Add ITEM to AGENDA, returning ITEM.
There is an around method which arranges for ITEM to be returned.")
(:method :around ((agenda agenda) item)
(call-next-method)
item))
(defgeneric agenda-add-items (agenda items &key ordered)
(:documentation "Add ITEMS to AGENDA.
If ORDERED is true do so in a way that AGENDA-NEXT-ITEM will pull them
off in the same order. Return AGENDA (there is an around method which
arranges for this). The default method just adds the items in the
order given.")
(:method :around ((agenda agenda) items &key ordered)
(declare (ignorable ordered))
(call-next-method)
agenda)
(:method ((agenda agenda) items &key ordered)
(declare (ignorable ordered))
(loop for item in items
do (agenda-add-item agenda item))))
;;;; Queues are FIFO agendas
;;;
(defclass queue (agenda)
((q :initform (cons nil nil)))
(:documentation "A queue"))
(defmethod agenda-empty-p ((queue queue))
(null (car (slot-value queue 'q))))
(defmethod agenda-next-item ((queue queue))
(let* ((q (slot-value queue 'q))
(item (pop (car q))))
(when (null (car q))
(setf (cdr q) nil))
item))
(defmethod agenda-add-item ((queue queue) item)
(let ((q (slot-value queue 'q))
(item-holder (list item)))
(if (null (car q))
(setf (car q) item-holder
(cdr q) item-holder)
(setf (cdr (cdr q)) item-holder
(cdr q) item-holder))))
;;;; Stacks are LIFO agendas
;;;
(defclass stack (agenda)
((s :initform '()))
(:documentation "A stack"))
(defmethod agenda-empty-p ((stack stack))
(null (slot-value stack 's)))
(defmethod agenda-next-item ((stack stack))
(pop (slot-value stack 's)))
(defmethod agenda-add-item ((stack stack) item)
(push item (slot-value stack 's)))
(defmethod agenda-add-items ((stack stack) items &key ordered)
(loop for item in (if ordered (reverse items) items)
do (agenda-add-item stack item)))
;;;; Searching with agendas
;;;
(defun tree-search (tree predicate &key (agenda-class 'stack))
;; search TREE using PREDICATE. AGENDA-CLASS (default STACK)
;; defines the type of search: a STACK will result in a depth-first
;; search while a QUEUE will result in a breadth-first search. This
;; is a wrapper around AGENDA-SEARCH.
(agenda-search (make-instance agenda-class :item tree) predicate))
(defun agenda-search (agenda predicate)
;; Search using an agenda. PREDICATE is compared against the value
;; of a tree node. On success return the node matched and the
;; agenda, on failure return NIL and NIL. If the returned agenda is
;; not empty it can be used to restart the search.
(loop while (not (agenda-empty-p agenda))
for node = (agenda-next-item agenda)
when (funcall predicate (tree-node-value node))
do (return-from agenda-search
(values node agenda))
else do (agenda-add-items agenda (tree-node-children node)
:ordered t)
finally (return (values nil nil))))
I am a beginner with lisp.
I manipulate list of list:
((name1, second) (name2, second2))
The goal of my function is to get the second element of the list that have name as it first node.
For example:
my list is: ((name1, second1) (name2, second2))
getelement list name1 should return second1.
(defun getelement (list name)
(if (eq list '())
(if (string= (caar list) name)
(car (car (cdr list)))
(getelement (cdr list) name)
)
()
)
)
But I get this error. I really don't understand what is happening with my code. I tried to put ' before expressions...
Error: The variable LIST is unbound.
Fast links are on: do (si::use-fast-links nil) for debugging
Error signalled by IF.
Backtrace: IF
The if clauses are in the wrong order.
When the string matches, you are taking the next element (cdr) instead of that matching element (car)
This should work:
(defun getelement (list name)
(if (eq list '()) ;end of list,...
'() ;return empty list
(if (string= (caar list) name) ;matches,
(car (car list)) ;take the matching element
(getelement (cdr list) name))))
(defun get-element (list name)
(cadr (assoc name list :test #'string=)))
I can't figure, is there any way to put something like _ in erlang, for "unused value" in destructuring-bind?
For example there we have something like that:
(destructuring-bind ((_SNIPPET
(_TITLE . title)
(_DESCRIPTION . description)
_RESOURCE-ID (_VIDEO-ID . video-id)))) entry
(declare (ignore
_SNIPPET _TITLE _DESCRIPTION _RESOURCE-ID _VIDEO-ID))
(list video-id title description)))
It'll be great not to put specific variable for every unused value, and write something like that:
(destructuring-bind ((_
(_ . title)
(_ . description)
(_ (_ . video-id)))) entry
(list video-id title description)))
Is there any way to get such behavior with standart destructuring-bind or any other standart macros? Or I have to use some ML-like pattern matching library, and if so - which one?
It's not possible with DESTRUCTURING-BIND (you can't use a variable more than once, some compiler will complain). You can enumerate the variables, _1, _2, ... But then you have to ignore each of them.
LOOP can do it:
CL-USER 23 > (loop for ((a b nil c) nil d) in '(((1 2 3 4) 5 6)
((1 2 3 4) 5 6))
collect (list a b c d))
((1 2 4 6) (1 2 4 6))
NIL is used as the wildcard variable.
You can reuse the LOOP macro:
(defmacro match-bind (pattern object &body body)
`(loop with ,pattern = ,object
while nil
finally (return (progn ,#body))))
CL-USER 37 > (match-bind ((a b nil c) nil d)
'((1 2 3 4) 5 6)
(list a b c d))
(1 2 4 6)
You can use some LET-MATCH from some library. For example: https://github.com/schani/clickr/blob/master/let-match.lisp
There are probably more fancy versions.
There's nothing built into the language for this. Rainer Joswig's answer points out that loop can do some destructuring, but it doesn't do nearly as much. In an earlier version of this answer, I suggested traversing the destructuring lambda list and collecting a list of all the symbols that begin with _ and adding a declaration to the form to ignore those variables. A safer version replaces each one with a fresh variable (so that there are no repeated variables), and ignores them all. Thus something like
(destructuring-bind (_a (_b c)) object
c)
would expand into
(destructuring-bind (#:g1 (#:g2 c)) object
(declare (ignore #:g1 #:g2))
c)
This approach will work OK if you're only using the "data-directed" described in 3.4.4.1.1 Data-directed Destructuring by Lambda Lists. However, if you're using "lambda-list-directed" approach described in 3.4.4.1.2 Lambda-list-directed Destructuring by Lambda Lists, where you can use lambda-list keywords like &optional, &key, etc., then things are much more complicated, because you shouldn't replace variables in some parts of those. For instance, if you have
&optional (_x '_default-x)
then it might be OK to replace _x with something, but not _default-x, because the latter isn't a pattern. But, in Lisp, code is data, so we can still write a macro that maps over the destructuring-lambda-list and replaces only in locations that are patterns. Here's somewhat hairy code that does just that. This takes a function and a destructuring lambda list, and calls the function for each pattern variable in the lambda list, along with the type of the argument (whole, required, optional, etc.).
(defun map-dll (fn list)
(let ((result '())
(orig list)
(keywords '(&allow-other-keys &aux &body
&key &optional &rest &whole)))
(labels ((save (x)
(push x result))
(handle (type parameter)
(etypecase parameter
(list (map-dll fn parameter))
(symbol (funcall fn type parameter)))))
(macrolet ((parse-keyword ((&rest symbols) &body body)
`(progn
(when (and (not (atom list))
(member (first list) ',symbols))
(save (pop list))
,#body)))
(doparameters ((var) &body body)
`(do () ((or (atom list) (member (first list) keywords)))
(save (let ((,var (pop list)))
,#body)))))
(parse-keyword (&whole)
(save (handle :whole (pop list))))
(doparameters (required)
(handle :required required))
(parse-keyword (&optional)
(doparameters (opt)
(if (symbolp opt)
(handle :optional opt)
(list* (handle :optional (first opt)) (rest opt)))))
(when (and (atom list) (not (null list))) ; turn (... . REST)
(setq list (list '&rest list))) ; into (... &rest REST)
(parse-keyword (&rest &body)
(save (handle :rest (pop list))))
(parse-keyword (&key)
(doparameters (key)
(if (symbolp key)
(handle :key key)
(destructuring-bind (keyspec . more) key
(if (symbolp keyspec)
(list* (handle :key keyspec) more)
(destructuring-bind (keyword var) keyspec
(list* (list keyword (handle :key var)) more)))))))
(parse-keyword (&allow-other-keys))
(parse-keyword (&aux)
(doparameters (aux) aux))
(unless (null list)
(error "Bad destructuring lambda list: ~A." orig))
(nreverse result)))))
Using this, it's pretty easy to write a destructuring-bind* that replaces each pattern variable beginning with _ with a fresh variable that will be ignored in the body.
(defmacro destructuring-bind* (lambda-list object &body body)
(let* ((ignores '())
(lambda-list (map-dll (lambda (type var)
(declare (ignore type))
(if (and (> (length (symbol-name var)) 0)
(char= #\_ (char (symbol-name var) 0)))
(let ((var (gensym)))
(push var ignores)
var)
var))
lambda-list)))
`(destructuring-bind ,lambda-list ,object
(declare (ignore ,#(nreverse ignores)))
,#body)))
Now we should look at the expansions it produces:
(macroexpand-1
'(destructuring-bind* (&whole (a _ . b)
c _ d
&optional e (f '_f)
&key g _h
&aux (_i '_j))
object
(list a b c d e f g)))
;=>
(DESTRUCTURING-BIND
(&WHOLE (A #:G1041 &REST B) C #:G1042 D
&OPTIONAL E (F '_F)
&KEY G #:G1043
&AUX (_I '_J))
OBJECT
(DECLARE (IGNORE #:G1041 #:G1042 #:G1043))
(LIST A B C D E F G))
We haven't replaced anywhere we shouldn't (init forms, aux variables, etc.), but we've taken care of the places that we should. We can see this work in your example too:
(macroexpand-1
'(destructuring-bind* ((_ (_ . title)
(_ . description)
_
(_ . video-id)))
entry
(list video-id title description)))
;=>
(DESTRUCTURING-BIND ((#:G1044 (#:G1045 &REST TITLE)
(#:G1046 &REST DESCRIPTION)
#:G1047
(#:G1048 &REST VIDEO-ID)))
ENTRY
(DECLARE (IGNORE #:G1044 #:G1045 #:G1046 #:G1047 #:G1048))
(LIST VIDEO-ID TITLE DESCRIPTION))