I have a list:
*DSTATES* = ( ( list1 ) ( list2 ) ( list3 ) ... ( listn ) )
And a list of state names, x = ( list )
*DSTATES* has ( (zero) (three two one) (two) (three zero) )
x has (two).
Here's my code:
(map '() #'(lambda (x)
(princ "Looking at transition ") (princ x)
(princ #\newline)
(if (and (eq '() (member x *DSTATES*)) (not (eq '() x)))
(progn
(princ x) (princ " is not a member of *DSTATES*")
(princ #\newline)
(setq *DSTATES* (append *DSTATES* (list x)))))
(princ "Intermediate *DSTATES* ") (princ *DSTATES*)
(princ #\newline) (princ #\newline))
trans)
When I do ( eq '() ( member x *DSTATES* ) ) it always--as far as I can tell--returns true. Because of this *DSTATES* gets larger and larger and my loop, which has a stop condition on the size of *DSTATES* never terminates.
How can I fix this?
Simply do (member x *DSTATES* :test #'tree-equal)
That will make member check membership.
Hope that helps guys
how to test whether one list is a member of another
Related
I have to write the function that determines the number and values of block attributes in AutoLisp.
I have function which count the atributes:
(defun c:Test (/ s ss)
(if (and (princ "\n Select FIRST Attributed Block :")
(setq s (ssget "_+.:S:E" '((0 . "INSERT") (66 . 1))))
(princ "\n Select the SECOND Attributed Block :")
(setq ss (ssget "_+.:S:E" '((0 . "INSERT") (66 . 1))))
)
(mapcar
'length
(mapcar
'(lambda (a)
(mapcar
'(lambda (x) (vla-get-textstring x))
(vlax-invoke (vlax-ename->vla-object a) 'getattributes)
)
)
(list (ssname s 0) (ssname ss 0))
)
)
)
)**
A function that returns the values of attributes:
(defun c:Test (/ ss n e x)
(while (progn (princ "\n Select single attributed block :")
(setq ss (ssget "_+.:S" '((0 . "INSERT") (66 . 1))))
)
(setq n (entnext (ssname ss 0)))
(while (not (eq (cdr (assoc 0 (setq e (entget n)))) "SEQEND" ))
(if (eq (cdr (assoc 0 e)) "ATTRIB")
(print (cdr (assoc 1 e)))
)
(setq n (entnext n))
)
)
(princ)
)
Could you help me to combine this to functions into one?
Here is a lisp program that will loop over all blocks from a user selection set and:
1.) print block name
2.) print the association list of AttributeTag.AttributeValue
3.) print the list of AttributeTags
4.) print the list of AttributeValues
5.) print the number of AttributeValues
I also attached what the command line output should look like.
Lisp command line output
;;www.cadwiki.net
(defun c:test (/ SSINPUT)
(setq ssInput (ssget (list '(0 . "insert"))))
(PRINT-BLOCK-ATTRIBUTE-INFO ssInput)
(princ)
)
(defun PRINT-BLOCK-ATTRIBUTE-INFO (ssInput / ATTRIBUTETAGS ATTRIBUTETAGSTOVALUES ATTRIBUTEVALUES BLOCKENTITY BLOCKVLAOBJECT I NUMBEROFBLOCKATTRIBUTES
)
(setq i 0)
(if (= ssInput nil)
(progn
(princ "ssInput was nothing, exiting.")
(exit)
)
)
(princ (strcat "\nItems in selection set: " (itoa (sslength ssInput))))
(while (< i (sslength ssInput))
(setq blockEntity (ssname ssInput i))
(setq blockVlaObject (vlax-ename->vla-object blockEntity))
(setq attributeTagsToValues (GET-BLOCK-ATTRIBUTE-NAME-TO-VALUE-ASSOC blockEntity))
(princ (strcat "\nBlock name: " (vla-get-name blockVlaObject)))
(princ "\nBlock attributes tag to values association list: ")
(princ attributeTagsToValues)
(setq attributeTags (GET-NTHS-FROM-LISTS 0 attributeTagsToValues nil))
(princ "\nBlock attribute tags list: ")
(princ attributeTags)
(setq attributeValues (GET-LAST-ITEM-FROM-EACH-LIST attributeTagsToValues))
(princ "\nBlock attributes values list: ")
(princ attributeValues)
(princ "\nNumber of block attributes: ")
(setq numberOfBlockAttributes (itoa (length attributeValues)))
(princ numberOfBlockAttributes)
(setq i (+ i 1))
)
)
(defun GET-NTHS-FROM-LISTS (N LSTs removeDuplicates / CT LST2 LST IT)
(setq LST2 nil)
(foreach LST LSTs
(setq IT (nth N LST))
(if removeDuplicates
(if (not (member IT LST2))
(setq LST2 (append LST2 (list IT)))
)
(setq LST2 (append LST2 (list IT)))
)
)
LST2
)
(defun GET-LAST-ITEM-FROM-EACH-LIST (LSTs / CDRs FAIL LST)
(setq CDRs nil
FAIL nil
)
(if (not (= (type LSTs) 'LIST))
(setq FAIL "not a list")
)
(if (not FAIL)
(foreach LST LSTs
(setq FAIL (cond
((not (= (type LST) 'LIST)) "non-list member")
((not (cdr LST)) "no CDR")
(T nil)
)
)
(if (not FAIL)
(setq CDRs (append CDRs (list (cdr LST))))
)
)
)
CDRs
)
(defun GET-BLOCK-ATTRIBUTE-NAME-TO-VALUE-ASSOC (entity / COUNTER COUNTER2 COUNTERMAX COUNTERMAX2 DXFCODE0 DXFCODE2 DXFCODE66 DXFCODE8 DXFCODECODE-1 ENTITIESTORETURN ENTITYDXFCODES *ERROR* RETURNLIST
SUPPLIEDTRUENAME TRUENAME ATTRIBUTETAG ATTRIBUTEVALUE DXFCODE-1 ENTITYNAMEFORDRILLING SUBLIST TAGSANDVALUES THECALLINGFUNCTIONSNAME
)
(setq counter 0) ;initialize counter to 0 for while loop
(if ;if
(/= entity nil) ;entity is not nil
(progn ;progn wrap
(setq entityDxfCodes (entget entity)) ;set the varaible entityDxfCodes to the list of entities from the en varaible
;; you can use the method here to find any value from a dxfCodecode
(setq dxfCode-1 (cdr (assoc -1 entityDxfCodes))) ;set dxfCode-1 to the second element of the item that has -1 as it's first element, this is the entity name
(setq dxfCode0 (cdr (assoc 0 entityDxfCodes))) ;set dxfCode0 to the element of the item that has 0 as it's first element, this is the entity type
(setq dxfCode2 (cdr (assoc 2 entityDxfCodes))) ;set dxfCode8 to the second element of the item that has 8 as it's first element, this is the name, or block name
(setq dxfCode8 (cdr (assoc 8 entityDxfCodes))) ;set dxfCode8 to the second element of the item that has 8 as it's first element, this is the layer
(setq dxfCode66 (cdr (assoc 66 entityDxfCodes))) ;set dxfCode66 to the second element of the item that has 66 as it's first element, this is the attribute flag
(setq entityNameForDrilling entity)
(if ;if start
(= dxfCode66 1) ;entity attribute flag is 1
(progn ;progn wrap
(while (/= dxfCode0 "SEQEND") ;while loop to drill to each sub entity in a block
(setq attributeTag (cdr (assoc 2 entityDxfCodes))) ;set attributeTag to the second element of the second Dxf code (assoc 2) of the entityDxfCodes variable
(setq attributeValue (cdr (assoc 1 entityDxfCodes))) ;set attributeValue to the second element of the first Dxf code (assoc 1) of the entityDxfCodes variable
(if
(/= attributeValue nil)
(progn
(setq sublist (cons attributeTag attributeValue))
(setq tagsAndValues (cons sublist TagsAndValues))
)
)
(setq entityNameForDrilling (entnext entityNameForDrilling))
(setq entityDxfCodes (entget entityNameForDrilling))
(setq dxfCode0 (cdr (assoc 0 entityDxfCodes)))
)
) ;progn wrap end
) ;if end
) ;progn wrap end
) ;if end
(setq returnList tagsAndValues)
)
With these emac lisp definitions given to me I need to get the correct results for (defun operand (n ast)). Currently, the first child works like it's supposed to but for the second child (operand (- n 1) (cadr ast)) gives the second child as (INT_LITERAL pos) and not the rest of the child ((INT_LITERAL pos) (77)). Not sure where to go from here. As you can see I've done some guess and testing to fix my solution but nothing has worked yet. From my understanding when my results are nil that means that frame has no parent frame but I'm not sure why it does not print out the whole operand.
(defun store (offset value alist)
"Insert the value for this offset, replacing the previous value (if any)."
(cond
((null alist) (list (cons offset value))) ; ((offset . value))
((eq offset (caar alist)) (cons (cons offset value) (cdr alist)))
(t (cons (car alist)
(store offset value (cdr alist))))
)
)
(defun lookup (offset alist)
"Return the value associated with this offset, or raise an error."
(cond
((null alist) (user-error "UNINITIALISED %s" offset) (exit))
((eq (caar alist) offset) (cdar alist))
(t (lookup offset (cdr alist)))
)
)
;;(setq a (store 1 19 (store 0 17 ())))
;; a
;; (setq a (store 2 20 a))
;; (setq a (store 1 29 a))
;; (lookup 3 ())
;; (lookup 3 a)
;;(lookup 1 a)
;;; Accessors for the various fields in an AST node
(defun position (ast)
"The position stored in an AST node"
(cadar ast)
)
(defun kind (ast)
(caar ast)
)
(defun operand (n ast)
;; Your code goes here.
(if (eq n 0)
(caadr ast) ;;first child
(operand (- n 1)(cadr ast)) ;;second child
)
)
;;(operand (- n 1)(cadr (cadr ast))) gives 77 (#o115, #x4d, ?M)
;;(operand (- n 1)(cadr ast)) gives (INT_LITERAL pos)
;;(operand (- n 1) (cadr (cddr ast))) gives nil
;;(operand (- n 1) (cdr (cadr ast))) gives nil
;; (operand (- n 1)(caddr ast)) gives nil
;;(operand (- n 1)(car ast)) gives wrong type argument listp, pos
;;(operand (- n 1)(cdr ast)) gives nil
;;cadadr, cadr, cadddr, cdadr, caddr, car, cdr
;; (setq ast '((PLUS pos) (( (VARIABLE pos) (b 1) ) ((INT_LITERAL pos) (77) ) ) ))
;; (kind ast) = PLUS
;; (position ast) = pos
;; (operand 0 at) = ((VARIABLE pos)(b 1))
;; (kind (operand 0 ast))= VARIABLE
;; (operand 1 ast)= supposed to equal ((INT_LITERAL pos) (77))
;; (kind (operand 1 ast)) = supposed to equal INT_LITERAL
Your question is not easy to follow -- I'm confident that you could pare all that code down to something far more minimal for these purposes.
At present you're calling operand recursively, but the ast data does not have the nested structure required by that recursion, and so things quickly break down.
I think you just want this?
(defun operand (n ast)
(nth n (cadr ast)))
I'm trying to create an array of lists with its elements being: Surname , Name and Age.
Here is my code in AutoLISP:
(defun C:DP_ADINREG ( / prenume nume varsta inreg)
(initget 1)
(setq prenume (getstring "\nIntroduceti prenumele: "))
(initget 1)
(setq nume (getstring "\nIntroduceti numele: "))
(initget 7)
(setq varsta (getint "\nIntroduceti varsta: "))
(setq inreg (list (cons 'pn prenume) (cons 'nf nume)
(cons 'v varsta))
DP_DATA (append DP_DATA (list inreg))
)
(princ)
)
(defun C:DP_LISTARE ( / curent inreg n)
(setq curent DP_DATA
n 1)
(while curent
(setq inreg (car curent))
(princ (strcat "\nInregistrarea #" (itoa n)
": " (cdr (assoc 'pn inreg))
", " (cdr (assoc 'nf inreg))
". Varsta " (itoa (cdr (assoc 'v inreg)))
)
)
(setq curent (cdr curent)
n (1+ n)
)
)
(princ)
)
Problem is, when trying to access the second function, it gives me an error called:
Bad argument type : fixnump : nil.
Now I have no idea where the problem actually is.
Any ideas?
The error:
; error: bad argument type: fixnump: nil
Arises when a function requiring an integer argument is supplied with a value of nil. Hence, this error is arising from the evaluation of the second of your two itoa expressions:
(itoa (cdr (assoc 'v inreg)))
(Since the first itoa expression is being supplied with the variable n, which cannot be nil).
This implies that the following expression returns nil:
(cdr (assoc 'v inreg))
Which implies that one of the association lists within the list held by your global variable DP_DATA does not contain a dotted pair with key v. I would therefore suggest checking the value held by your global variable DP_DATA.
Aside: note that initget has no effect on a getstring prompt - you can achieve the same effect using a basic while loop, e.g.:
(while (= "" (setq prenume (getstring "\nIntroduceti prenumele: ")))
(princ "\nPlease enter a first name.")
)
(while (= "" (setq nume (getstring "\nIntroduceti numele: ")))
(princ "\nPlease enter a surname.")
)
You can account for null values in your association list using some basic error checking:
(defun C:DP_ADINREG ( / prenume nume varsta )
(while (= "" (setq prenume (getstring "\nIntroduceti prenumele: ")))
(princ "\nPlease enter a first name.")
)
(while (= "" (setq nume (getstring "\nIntroduceti numele: ")))
(princ "\nPlease enter a surname.")
)
(initget 7)
(setq varsta (getint "\nIntroduceti varsta: ")
DP_DATA (cons (list (cons 'pn prenume) (cons 'nf nume) (cons 'v varsta)) DP_DATA)
)
(princ)
)
(defun C:DP_LISTARE ( / n )
(setq n 0)
(foreach lst (reverse DP_DATA)
(princ
(strcat
"\nInregistrarea #" (itoa (setq n (1+ n)))
": " (cond ((cdr (assoc 'pn lst))) (""))
", " (cond ((cdr (assoc 'nf lst))) (""))
". Varsta " (itoa (cond ((cdr (assoc 'v lst))) (0)))
)
)
)
(princ)
)
The above will return a blank first name/surname where not present, and an age of 0 where not present; you could alternatively return an error if these values are not present, e.g.:
(defun C:DP_LISTARE ( / n nf pn v )
(setq n 1)
(foreach lst (reverse DP_DATA)
(if
(and
(setq pn (cdr (assoc 'pn lst)))
(setq nf (cdr (assoc 'nf lst)))
(setq v (cdr (assoc 'v lst)))
)
(princ (strcat "\nInregistrarea #" (itoa n) ": " pn ", " nf ". Varsta " (itoa v)))
(princ (strcat "\nMissing data for item " (itoa n)))
)
(setq n (1+ n))
)
(princ)
)
"Learning" Lisp for school but don't feel I'm learning correctly. I'm trying to write a function to add all the numbers in a list that is composed of lists, numbers, and strings. I'm ignoring the strings and entering the lists. I'm getting quite lost with all the parenthesis...
Im receiving the error Illegal argument in functor position 0
(defun add-all (L)
(cond
(
(null L)
(0)
)
(
(listp (car L) )
(+ (add-all (car L)) (add-all (cdr L)) )
)
(
(stringp (car L) )
(+ (add-all (cdr L)) )
)
(
t
(+ (car L) (add-all (cdr L)) )
)
)
)
You are attempting to call the function 0 in the first clause of your cond. ie. (0). This is the fixed code formatted for readability.
(defun add-all (list)
(cond
((null list) 0)
((listp (car list)) (+ (add-all (car list)) (add-all (cdr list))))
((stringp (car list)) (+ (add-all (cdr list))))
(t (+ (car list) (add-all (cdr list))))))
May I ask why are you handling strings in the list?
As an extra, I recommend you use a text editor that can format the code and balance the parens for you. Emacs is the best choice.
Also this code is more 'scheme'y than lispy. What book are you using to learn lisp if I may ask.
In the first clause of cond you have:
(
(null L)
(0)
)
I think you want:
(
(null L)
0
)
... without the parens.
I am a beginner in LISP and I'm working on an exercise that requires me to make modifications to a breath-first search in order to convert it to a uniform-cost search.
Needless to say, I am extremely confused. I understand the basics of how breadth-first search and how uniform-cost search work, but I am having trouble implementing it.
I have some code for breadth-first search as well as the structure of nodes and expansion methods below, but I am having trouble in developing the uniform-cost search.
I understand it is supposed to take the lowest cost path, but I am not sure how to implement it all. I don't quite understand how it is supposed to save all those paths and edges while working through the entire map (the map of which I'm working with is the Romania Road Map, I'm sure google will bring up a copy)
Anyways the code I have so far is below:
;The Problem:
setq ex2 '(
(Arad ( (Zerind 75) (Sibiu 140) (Timisoara 118) ) )
(Oradea ( (Zerind 71) (Sibiu 151) ) )
(Zerind ( (Oradea 71) (Arad 75) ) )
(Timisoara ( (Lugoj 111) (Arad 118) ) )
(Lugoj ( (Timisoara 111) (Medhadia 70) ) )
(Mehadia ( (Lugoj 70) (Drobeta 75) ) )
(Drobeta ( (Mehadia 75) (Craiova 120) ) )
(Sibiu ( (Oradea 151) (Arad 140) (Rimnicu-Vilcea 80) (Fagaras 99) ) )
(Rimnicu-Vilcea ( (Sibiu 80) (Craiova 146) (Pitesti 97) ) )
(Craiova ( (Rimnicu-Vilcea 146) (Drobeta 120) (Pitesti 138) ) )
(Fagaras ( (Sibiu 99) (Bucharest 211) ) )
(Pitesti ( (Rimnicu-Vilcea 97) (Craiova 138) (Bucharest 101) ) )
(Bucharest ( (Fagaras 211) (Pitesti 101) (Giurgiu 90) (Urziceni 85) ) )
(Giurgiu ( (Bucharest 90) ) )
(Neami ( (Iasi 87) ) )
(Iasi ( (Neami 87) (Vasiui 92) ) )
(Vasiui ( (Iasi 92) (Urziceni 142) ) )
(Urziceni ( (Bucharest 85) (Hirsova 98) (Vasiui 142) ) )
(Hirsova ( (Urziceni 98) (Eforie 86) ) )
(Eforie ( (Hirsova 86) ) )
) )
(setq problem3 (list 'Arad 'Bucharest ex2))
;return the start state from a problem
(defun initial-state (problem)
(car problem))
; return the goal state from a problem
(defun goal-state (problem)
(cadr problem))
; return the successor list from a problem
(defun adj-list (problem)
(caddr problem))
; construct a node from a state and a parent state
(defun make-node (state parent value depth)
(list state parent value depth))
; get the state from a node
(defun get-state (node)
(car node))
; get the parent state from a node
(defun get-parent (node)
(cadr node))
; get the value from a node
(defun get-value (node)
(caddr node))
; get the depth from a node
(defun get-depth (node)
(cadddr node))
;determine if a node represents the goal of a problem
(defun goal-test (problem node)
(cond ((equal (goal-state problem) (get-state node)) T)
(T nil)))
; create a list of nodes which represents the states adjacent to the state represented by node
(defun expand (node problem)
(expand-aux node (cadr (assoc (get-state node) (adj-list problem))) nil ))
; helper function for expand
(defun expand-aux (node states L)
(cond ((null states) L)
(T (expand-aux node
(cdr states)
(append L (list (make-node (caar states)
(get-state node)
(+ (get-value node) (cadar states))
(+ (get-depth node) 1) )))))))
; recover the solution path from the final (goal) node and the list of expanded nodes
(defun solution (node nodes)
(solution-aux node nodes nil))
; helper function for solution
(defun solution-aux (node nodes L &aux temp)
(setq temp (parent node nodes))
(cond ((equal temp nil) (cons (get-state node) L))
(T (solution-aux temp nodes (cons (get-state node) L)))))
; find the parent node of a node in a list of nodes
(defun parent (node nodes)
(assoc (get-parent node) nodes))
; determine if a node's state is already the state of a node in nodes
(defun already-present (node nodes)
(cond ((assoc (get-state node) nodes) T)
(T nil)))
;;;;; Breadth-first Search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun breadth (problem)
(breadth-aux problem ; the problem
(list (make-node (initial-state problem) nil 0 0)) ; the fringe list
nil)) ; the closed list
(defun breadth-aux (problem fringe closed)
(cond ((null fringe) ; no place else to look, so fail
'Failure)
((goal-test problem (car fringe)) ; we have reach the goal, so return solution
(solution (car fringe) closed))
((already-present (car fringe) closed) ; this state was already reached, so go
(breadth-aux problem ; on without processing it
(cdr fringe)
closed))
(T ; process this node and go on
(breadth-aux problem
(append (cdr fringe) (expand (car fringe) problem))
(cons (car fringe) closed)))))
;;;;;;; Uniform-cost Search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun uniform-cost (problem)
(uniform-aux problem
(list (make-node (initial-state problem) nil 0 0))
nil))
(defun uniform-aux (problem fringe closed)
(cond ((null fringe) 'Failure)
((goal-test problem (car fringe))
(solution (car fringe) closed))
((already-present (car fringe) closed)
(uniform-aux problem (cdr fringe) closed))
(T (uniform-aux problem
(append (cdr fringe) (expand
(car fringe)
problem))
(cons (car fringe) closed)))))