How do I go about finding the complete dependency tree for a given project in Common Lisp?
I've tried using (ql-dist:dependency-tree "my-project") which errors ((ql-dist:find-system "my-project") returns nil whether my system is loaded or not), and (slot-value (asdf/system:find-system "my-project") 'asdf/component:sideway-dependencies) seems to return only direct dependencies where I'm looking for the full tree (it also seems to return conditional/implementation-specific dependencies, such as sb-posix and sb-bsd-sockets, which I'd prefer to do without).
Is there a standard one-step way of doing this, or will I need to recursively walk the output of that sideway-dependencies slot and filter idiosyncratically?
Here's a crack at the solution:
Take 3 (this could probably be a its own project at this stage):
(defgeneric ->key (thing))
(defmethod ->key ((thing string))
(intern (string-upcase thing) :keyword))
(defmethod ->key ((thing symbol))
(if (keywordp thing)
thing
(intern (symbol-name thing) :keyword)))
(defgeneric dependencies-of (system))
(defmethod dependencies-of ((system symbol))
(mapcar #'->key (slot-value (asdf/system:find-system system) 'asdf/component:sideway-dependencies)))
(defun ordered-dep-tree (dep-tree)
(let ((res))
(labels ((in-res? (dep-name) (member dep-name res))
(insert-pass (remaining)
(loop for (dep . sub-deps) in remaining
for unmet-sub-deps = (remove-if #'in-res? sub-deps)
if (null unmet-sub-deps) do (push dep res)
else collect (cons dep unmet-sub-deps) into next-rems
finally (return next-rems))))
(loop for (dep . callers) in dep-tree for deps-of = (dependencies-of dep)
if (null deps-of) do (push dep res)
else collect (cons dep deps-of) into non-zeros
finally (loop while non-zeros
do (setf non-zeros (insert-pass non-zeros)))))
(reverse res)))
(defgeneric dependency-tree (system))
(defmethod dependency-tree ((system symbol))
(let ((res (make-hash-table)))
(labels ((rec (sys)
(loop with deps = (dependencies-of sys)
for dep in deps for dep-k = (->key dep)
unless (gethash dep-k res) do (rec dep)
do (pushnew (->key sys) (gethash dep-k res)))))
(rec system))
(ordered-dep-tree (alexandria:hash-table-alist res))))
That still doesn't filter for sb-*-style packages, but I figure I can do that in a separate pass. It seems to work though...
CL-USER> (dependency-tree :hunchentoot)
(:SB-BSD-SOCKETS :TRIVIAL-BACKTRACE :RFC2388 :SB-ROTATE-BYTE
:TRIVIAL-GARBAGE :TRIVIAL-FEATURES :CL-PPCRE :ALEXANDRIA :SB-POSIX
:CL-BASE64 :TRIVIAL-GRAY-STREAMS :USOCKET :MD5 :BABEL :FLEXI-STREAMS
:BORDEAUX-THREADS :CHUNGA :CFFI :CL-FAD :CL+SSL)
I think that's a list of all packages that need to be loaded before :hunchentoot, presented in an order they can be loaded (no package appears before all of its dependencies appear). It doesn't handle circular dependencies, but I don't think asdf does either, so...
Related
Edit: Title updated to reflect what my question should have been, and hopefully lead other users here when they have the same problem.
Little bit of a mess, but this is a work-in-progress common lisp implementation of anydice that should output some ascii art representing a probability density function for a hash-table representing dice rolls. I've been trying to figure out exactly why, but I keep getting the error *** - SYSTEM::READ-EVAL-READER: variable BAR-CHARS has no value when attempting to run the file in clisp. The error is originating from the output function.
The code is messy and convoluted (but was previously working if the inner most loop of output is replaced with something simpler), but this specific error does not make sense to me. Am I not allowed to access the outer let* variables/bindings/whatever from the inner most loop/cond? Even when I substitute bar-chars for the list form directly, I get another error that char-decimal has no value either. I'm sure there's something about the loop macro interacting with the cond macro I'm missing, or the difference between setf, let*, multiple-value-bind, etc. But I've been trying to debug this specific problem for hours with no luck.
(defun sides-to-sequence (sides)
(check-type sides integer)
(loop for n from 1 below (1+ sides) by 1 collect n))
(defun sequence-to-distribution (sequence)
(check-type sequence list)
(setf distribution (make-hash-table))
(loop for x in sequence
do (setf (gethash x distribution) (1+ (gethash x distribution 0))))
distribution)
(defun distribution-to-sequence (distribution)
(check-type distribution hash-table)
(loop for key being each hash-key of distribution
using (hash-value value) nconc (loop repeat value collect key)))
(defun combinations (&rest lists)
(if (endp lists)
(list nil)
(mapcan (lambda (inner-val)
(mapcar (lambda (outer-val)
(cons outer-val
inner-val))
(car lists)))
(apply #'combinations (cdr lists)))))
(defun mapcar* (func lists) (mapcar (lambda (args) (apply func args)) lists))
(defun dice (left right)
(setf diceprobhash (make-hash-table))
(cond ((integerp right)
(setf right-distribution
(sequence-to-distribution (sides-to-sequence right))))
((listp right)
(setf right-distribution (sequence-to-distribution right)))
((typep right 'hash-table) (setf right-distribution right))
(t (error (make-condition 'type-error :datum right
:expected-type
(list 'integer 'list 'hash-table)))))
(cond ((integerp left)
(sequence-to-distribution
(mapcar* #'+
(apply 'combinations
(loop repeat left collect
(distribution-to-sequence right-distribution))))))
(t (error (make-condition 'type-error :datum left
:expected-type
(list 'integer))))))
(defmacro d (arg1 &optional arg2)
`(dice ,#(if (null arg2) (list 1 arg1) (list arg1 arg2))))
(defun distribution-to-probability (distribution)
(setf probability-distribution (make-hash-table))
(setf total-outcome-count
(loop for value being the hash-values of distribution sum value))
(loop for key being each hash-key of distribution using (hash-value value)
do (setf (gethash key probability-distribution)
(float (/ (gethash key distribution) total-outcome-count))))
probability-distribution)
(defun output (distribution)
(check-type distribution hash-table)
(format t " # %~%")
(let* ((bar-chars (list 9617 9615 9614 9613 9612 9611 9610 9609 9608))
(bar-width 100)
(bar-width-eighths (* bar-width 8))
(probability-distribution (distribution-to-probability distribution)))
(loop for key being each hash-key of
probability-distribution using (hash-value value)
do (format t "~4d ~5,2f ~{~a~}~%" key (* 100 value)
(loop for i from 0 below bar-width
do (setf (values char-column char-decimal)
(truncate (* value bar-width)))
collect
(cond ((< i char-column)
#.(code-char (car (last bar-chars))))
((> i char-column)
#.(code-char (first bar-chars)))
(t
#.(code-char (nth (truncate
(* 8 (- 1 char-decimal)))
bar-chars)))))))))
(output (d 2 (d 2 6)))
This is my first common lisp program I've hacked together, so I don't really want any criticism about formatting/style/performance/design/etc as I know it could all be better. Just curious what little detail I'm missing in the output function that is causing errors. And felt it necessary to include the whole file for debugging purposes.
loops scoping is perfectly conventional. But as jkiiski says, #. causes the following form to be evaluated at read time: bar-chars is not bound then.
Your code is sufficiently confusing that I can't work out whether there's any purpose to read-time evaluation like this. But almost certainly there is not: the uses for it are fairly rare.
I am building a window application in Lisp using the LTK library. I want a button that does an action and, possibly, hides itself. However, this code:
(let* ((left (button 0 0 f "←" #'(lambda ()
(decf start page-length)
(funcall redraw)
(if (>= start page-length)
(ltk:configure left :state :visible))
(ltk:configure left :state :hidden))))))
claims that "left" is an undefined variable (the rest is defined in code beyond the scope of this problem).
Worst case scenario, I avoid the "button" function I wrote and rework the code for this particular situation, but the scenario begs a general solution. Is there any way in Lisp to use a variable in a function in the definition of the variable?
A let* with only one binding is the same as a let binding. A let binding does not exist until the body is executed. During the execution of button the reference for left must be from an earlier closure or global as left is created after the expression is evaluated. You can do this:
(let ((left nil))
(setf left (button 0 0 f "←" #'(lambda ()
(decf start page-length)
(funcall redraw)
(if (>= start page-length)
(ltk:configure left :state :visible)
(ltk:configure left :state :hidden))))))
NB: There was a bug in the if such that the lambda always would execute (ltk:configure left :state :hidden)
For what it's worth here is a version of letrec in CL:
(defmacro letrec (bindings &body decls/forms)
(assert (and (listp bindings)
(every (lambda (b)
(or (symbolp b)
(and (consp b)
(symbolp (first b))
(null (cddr b)))))
bindings))
(bindings) "malformed bindings")
(multiple-value-bind (names values)
(loop for b in bindings
collect (etypecase b
(symbol b)
(cons (first b)))
into vars
collect (etypecase b
(symbol nil)
(cons (second b)))
into vals
finally (return (values vars vals)))
`(let ,names
(psetf ,#(loop for name in names
for val in values
collect name
collect val))
(locally
,#decls/forms))))
Then
> (letrec ((x (lambda (y)
(if (null y)
'done
(funcall x (cdr y))))))
(funcall x '(1 2 3)))
done
I am trying to make a 'pseudo OO system':
(defun bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
(defparameter bank-account-object (bank-account))
(funcall (funcall bank-account-object 'init) 42)
(funcall (funcall bank-account-object 'increment) 10)
(funcall (funcall bank-account-object 'get-balance))
Q: are there better ways to accomplish the same without using CLOS, defstruct, or defmacro?
The problem that I see with this is that it is closed for extension, and I see no simple way to add extensibility.
Minor nitpick: that's not a bank-system but a bank-account. When you think about that further, it seems to me that the interesting part about this example domain has not been touched: double accounting, i. e. ensuring the null-sum invariant.
There are two sayings: a closure is a poor man's object, and an object is a poor man's closure. I have the feeling that you are more in the realm of the former here. However, it might be a good learning experience to think about this—as long as you don't put it into production somewhere…
;; The "class"
(defun create-bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
;; The "methods"
(defun init-balance (object amount)
(funcall (funcall object 'init) amount))
(defun increment-balance (object amount)
(funcall (funcall object 'increment) amount))
(defun get-balance (object)
(funcall (funcall object 'get-balance)))
;; Example usage
(defparameter bank-account (create-bank-account))
(init-balance bank-account 42) ; => 42
(increment-balance bank-account 10) ; => 52
(get-balance bank-account) ; => 52
As mentioned in other answers, the resulting object might be hard to extend. That could be a feature, but one possible way to improve on it is to let it be redefined dynamically. You can even switch from classes to protoypes.
(ql:quickload :optima)
(defpackage :obj (:use :cl :optima))
(in-package :obj)
(defun make-object (&optional prototype)
(let ((properties (make-hash-table :test #'eq))
(self))
(flet ((resolve (key)
(or (gethash key properties)
(and prototype (funcall prototype :get key)))))
(setf self
(lambda (&rest args)
(optima:ematch args
((list :get :prototype) prototype)
((list :get key) (resolve key))
((list :set :prototype p)
(cerror "Continue" "Changing prototype object, are you sure?")
(setf prototype p))
((list :set key value)
(if value
(setf (gethash key properties) value)
(remhash key properties)))
((list :invoke method args)
(let ((resolved (resolve method)))
(if resolved
(apply resolved self args)
(funcall (or (resolve :no-such-method)
(error "No such method: ~a in ~a"
method
self))
self
method))))))))))
Some helper symbols:
;; call built-in command
(defmacro $ (obj method &rest args)
`(funcall ,obj ,method ,#args))
;; access property
(declaim (inline # (setf #)))
(defun # (o k) ($ o :get k))
(defun (setf #) (v o k) ($ o :set k v))
;; invoke method
(defun % (o m &rest a)
($ o :invoke m a))
A simple test
(let ((a (make-object)))
;; set name property
(setf (# a :name) "a")
;; inherit
(let ((b (make-object a)))
(print (list (# b :name)
;; shadow name property
(setf (# b :name) "b")
(# a :name)))
;; define a method
(setf (# a :foo) (lambda (self) (print "FOO")))
;; invoke it
(% a :foo)))
Bank account
(defun create-bank-account (&optional parent)
(let ((account (make-object parent)))
(prog1 account
(setf (# account :init)
(lambda (self x)
(setf (# self :balance) x)))
(setf (# account :increment)
(lambda (self increment)
(incf (# self :balance) increment))))))
(let ((account (create-bank-account)))
(% account :init 0)
(% account :increment 100)
(# account :balance))
100
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))))
I am trying to solve problems on LISP and I am stuck with this problem for many days.
"Write a function, called wheres-waldo, that takes a lisp object (i.e., a data structure built from conses) as argument and returns a Lisp expression that extracts the symbol waldo from this object, if it is present"
For example,
E.g: (wheres-waldo '(emerson ralph waldo)) =
OUTPUT: (FIRST (REST (REST '(EMERSON RALPH WALDO))))
E.g: (wheres-waldo '(mentor (ralph waldo emerson) (henry david thoreau))) =
OUTPUT: (FIRST (REST (FIRST (REST
'(MENTOR (RALPH WALDO EMERSON)
(HENRY DAVID THOREAU))))))
I have written some recursion for example,
(defun wheres-waldo(lispOBJ)
(cond ((null lispOBJ) nil)
(equalp (first lispOBJ) waldo)
( t (***stuck here how to write recursion for this***))
)
I found this question from http://ai.eecs.umich.edu/people/wellman/courses/eecs492/f94/MP1.html wheres-waldo.
Any help would be appreciated. Thank you.
You need to loop over a list, and if an element is a list, recurse into the sublist, exactly as you would implement a deep search. The only difference is that, in order to produce the required output, you need to carry on the s-expression retracing the functions you used to get there.
Here is one possible implementation. Note that I have used the more traditional car and cdr instead of first and rest - they are equivalent.
(defun whereis (who obj &optional (sexp (list 'quote obj)))
(cond
; we found the object - return the s-expr
((eq obj who) sexp)
; try car and the cdr
((and obj (listp obj))
(or (whereis who (car obj) (list 'car sexp))
(whereis who (cdr obj) (list 'cdr sexp))))))
then:
? (whereis 'waldo '(emerson ralph waldo))
(CAR (CDR (CDR '(EMERSON RALPH WALDO))))
? (whereis 'waldo '(mentor (ralph waldo emerson) (henry david thoreau)))
(CAR (CDR (CAR (CDR '(MENTOR (RALPH WALDO EMERSON) (HENRY DAVID THOREAU))))))
? (whereis 'thoreau '(mentor (ralph waldo emerson) (henry david thoreau)))
(CAR (CDR (CDR (CAR (CDR (CDR '(MENTOR (RALPH WALDO EMERSON) (HENRY DAVID THOREAU))))))))
? (whereis 'scotty '(beam me up . scotty))
(CDR (CDR (CDR '(BEAM ME UP . SCOTTY))))
? (whereis 'waldo '(emerson ralph))
NIL
If your element can appear more than once, you could also build a list of results:
? (whereis 'c '(a b c d c b a))
((CAR (CDR (CDR '(A B C D C B A)))) (CAR (CDR (CDR (CDR (CDR '(A B C D C B A)))))))
with this code:
(defun whereis (who obj)
(let ((res nil)) ; the final result
(labels
; sub-function: walks the whole list recursively
((sub (obj sexp)
; found it - add to result list
(when (eq obj who) (setf res (cons sexp res)))
; try car and cdr
(when (and obj (listp obj))
(sub (cdr obj) (list 'cdr sexp))
(sub (car obj) (list 'car sexp)))))
; call sub-function
(sub obj (list 'quote obj)))
res))
The main problem with your approach is that if first elements equals waldo, how are you suppose to generate the answer? There may be many possible paths waldo might be in so we need a way to indicate in the iteration what path we are on and we need to backtrack if we are at a dead end.
(defun wheres-waldo (o)
(labels ; labels is to make local functions
((aux (cur acc) ; define loacl function aux with args cur and acc
(or ; or stops at the first non NIL value
(and (eq cur 'waldo) acc) ; if (eq cur 'waldo) we return acc
(and (consp cur) ; (else) if object is a cons
(or ; then one of the followin
(aux (car cur) (list 'first acc)) ; answer might be in the car
(aux (cdr cur) (list 'rest acc))))))) ; or the cdr of the cons
(aux o (list 'quote o)))) ; call aux with original object and the same object quoted. (list 'quote x) ==> 'x (as data)
As you see, main work is done by aux that has an object and an accumuolator idicating the path and the quotes data. If you find waldo then the result is the accumulator.
If waldo exists in several locations it always do car first so not necessarily the shortest answer but the first it finds.
I use and/or here. These are similar to if except it's the value of the expression that gets returned. Eg (and (eq cur 'waldo) acc) will make sure we return acc if cur is waldo since and evaluates to the last true value. If there is one NIL value it becomes the result of the form. For or it will evaluate to the first true value (everything not NIL) or NIL if all expressions mounts to NIL. In Exercise 2 of your link you were to rewrite a function in a similar way.
That is not where you are stuck. You are stuck at devising a strategy, not at writing code.
You will have to do a tree search (the thing you call a "lisp object" is actually just a cons tree—"lisp object" is a misleading term because in Lisp, a lot of things are objects, not just conses). Decide whether to do a breadth-first or depth-first search, how to accumulate the accessor path, and how to communicate the match or mismatch up the call tree.
Sometimes it's a bit easier to approach a slightly more general problem, and then figure out how to specialize it to the particular problem at hand. In this case, you're handed a structure of some sort, along with a number of accessors that can access substructures of that structure. Given an element to find, and a thing to search, you can search by checking whether the thing is the element, and if is, then returning the path so far (in an appropriate format), and if it's not, then if it's a structure that you can decompose with the accessors, try each decomposed part.
(defun find-element (element structure structure-p accessors &key (test 'eql))
(labels ((fe (thing path)
"If THING and ELEMENT are the same (under TEST), then
return PATH. Otherwise, if THING is a structure (as
checked with STRUCTURE-P), then iterate through
ACCESSORS and recurse on the result of each one
applied to THING."
(if (funcall test thing element)
;; return from the top level FIND-ELEMENT
;; call, not just from FE.
(return-from find-element path)
;; When THING is a structure, see what
;; each of the ACCESSORS returns, and
;; make a recursive call with it.
(when (funcall structure-p thing)
(dolist (accessor accessors)
(fe (funcall accessor thing)
(list* accessor path)))))))
;; Call the helper function
;; with an initial empty path
(fe structure '())))
This will return the sequence of accessors that we need, in reverse order that they need to be applied to structure. For instance:
(find-element 'waldo '(ralph waldo emerson) 'consp '(car cdr))
;=> (CAR CDR)
because (car (cdr '(ralph waldo emerson))) is waldo. Similarly
(find-element 'emerson '(ralph (waldo emerson)) 'consp '(first rest))
;=> (FIRST REST FIRST REST)
because (first (rest (first (rest '(ralph (waldo emerson)))))) is emerson. So we've solved the problem of getting a list of accessor functions. Now we need to build up the actual expression. This is actually a fairly simple task using reduce:
(defun build-expression (accessor-path structure)
(reduce 'list accessor-path
:initial-value (list 'quote structure)
:from-end t))
This works in the way we need it to, as long as we also provide a the structure. For instance:
(build-expression '(frog-on bump-on log-on hole-in bottom-of) '(the sea))
;=> (FROG-ON (BUMP-ON (LOG-ON (HOLE-IN (BOTTOM-OF '(THE SEA))))))
(build-expression '(branch-on limb-on tree-in bog-down-in) '(the valley o))
;=> (BRANCH-ON (LIMB-ON (TREE-IN (BOG-DOWN-IN '(THE VALLEY O)))))
Now we just need to put these together:
(defun where-is-waldo? (object)
(build-expression
(find-element 'waldo object 'consp '(first rest))
object))
This works like we want:
(where-is-waldo? '(ralph waldo emerson))
;=> (FIRST (REST '(RALPH WALDO EMERSON)))
(where-is-waldo? '(mentor (ralph waldo emerson) (henry david thoreau)))
;=> (FIRST (REST (FIRST (REST '(MENTOR (RALPH WALDO EMERSON) (HENRY DAVID THOREAU))))))