I have a problem with common lisp.
I want to pass a string to a function
and want that this strings become a structure.
I can't use external library.
For example with this input:
(testfu "ftp/http.ok:3345")
This is the struct:
(defstruct test-struct
scheme
part
ans
port)
I want this result:
scheme: "ftp" part: "http" ans "ok" port "3345"
How can I do the testfu ?
here my bad try :(
(defun testfu (x)
(setq ur1 (make-test-struct :scheme frist x :host second x)))
I'd recommend using a regex to parse this. Using CL-PPCRE which is the Common Lisp regex library, the code would look like this:
(defun testfu (x)
(multiple-value-bind (result values)
(ppcre:scan-to-strings "^([a-z]+)/([a-z]+)\\.([a-z]+):([0-9]+)$" x)
(unless result
(error "String ~s is not valid" x))
(make-test-struct :scheme (aref values 0)
:part (aref values 1)
:ans (aref values 2)
:port (aref values 3))))
Note that you probably would have to adjust the regex to better represent the actual format of the input string, in particular if any of the fields are optional.
You will have to parse the data out of the string in order that you might use it for your strut. Lisp won't do that magically.
Split Sequence is a good library for doing that
If you don't want a library, then some code to get you on the correct track. This will tokenize string based on a predicate function fn ( which returns true when a character is a delimiter and false otherwise )
(defun split-by-fn (fn string)
(let* ((STARTING 0)
(TOKEN 1)
(DELIM 2)
(state STARTING)
(a-token "")
(the-list '())
(str-length (length string)))
(dotimes (i str-length)
(if (funcall fn (char string i))
(progn
(if (eq state TOKEN)
(progn
(setq the-list (cons a-token the-list))
(setq a-token "")))
(setq state DELIM))
(progn
(setq a-token
(concatenate 'string a-token (string (char string i))))
(setq state TOKEN))))
(if (eq state TOKEN)
(setq the-list (cons a-token the-list)))
(setq the-list (reverse the-list))))
I don't usually write code for people but here is an example parser, it's not the most lisp-y, there are better ways of doing this, but it works.
(defun parser ( string )
(labels ((set-field (state struct token)
(let ((SCHEME 0)
(PART 1)
(ANS 2)
(PORT 3))
(cond ((= state SCHEME)
(setf (example-struct-SCHEME struct) token))
((= state PART)
(setf (example-struct-PART struct) token))
((= state ANS)
(setf (example-struct-ANS struct) token))
((= state PORT)
(setf (example-struct-PORT struct) token))))))
(let ((state 0)
(token "")
(check 0)
(a-list '())
(struct (make-example-struct)))
(loop for char across string do
(progn
(setq check (position char "/.:"))
(if check
(progn
(set-field state struct token)
(setq token "")
(setq state (+ check 1)))
(setq token (concatenate 'string token (string char))))))
(progn
(if (/= 0 (length token))
(set-field state struct token))
struct))))
Related
I spent 3 hours trying to figure out to modify a string at point to different cases, e.g. isFailedUpgrade to IS_FAILED_UPGRADE.
I got to the point where i can get the string at point to a var text but has no idea how to update a string text to the desired case.
(defun change-case ()
(interactive)
(let* ((bounds (if (use-region-p)
(cons (region-beginning) (region-end))
(bounds-of-thing-at-point 'symbol)))
(text (buffer-substring-no-properties (car bounds) (cdr bounds))))
(when bounds
(delete-region (car bounds) (cdr bounds))
(insert (change-case-helper text)))))
# the following code is rubbish
(defun change-case-helper (text)
(let ((output ""))
(dotimes (i (length text))
(concat output (char-to-string (aref text i))))
output))
Since i am on the journey to learn a little emacs function myself, i prefer to write this function myself instead of use an existing magical function.
ok after another 2 hours, i think i've figured it out:
(defun change-case ()
(interactive)
(let* ((bounds (if (use-region-p)
(cons (region-beginning) (region-end))
(bounds-of-thing-at-point 'symbol)))
(text (buffer-substring-no-properties (car bounds) (cdr bounds))))
(when bounds
(delete-region (car bounds) (cdr bounds))
(insert (change-case-helper text)))))
(defun change-case-helper (text)
(when (and text (> (length text) 0))
(let ((first-char (string-to-char (substring text 0 1)))
(rest-str (substring text 1)))
(concat (if (upcasep first-char) (string ?_ first-char) (string (upcase first-char)))
(change-case-helper rest-str))))
)
(defun upcasep (c) (and (= ?w (char-syntax c)) (= c (upcase c))))
still feel this is pretty awkward, please comment let me know if there is a better way of writing this function.
Say that I have a text file which is formatted like this:
(:question
(hello
how
are
you))
(:answer
(i
am
fine
thanks))
which I wish to read and then convert into a hashtable where the first words (starting with a :) are the keys, and then the inner lists are the values for the given keys. How can I do this? I have tried several approaches to this problem, but I cannot find a good way to read the file and then convert it to a hashtable.
Since you posted an attempt, it might be worth comparing how it could be done a little bit more simply. The loop macro supports a bunch of different clauses, and some can be very handy here. If I knew that I could read values of the form (key value) from a stream until there were no more values (in this case, until either a nil is read, or the end of stream is encountered), I'd do something like this:
(defun read-hashtable (&optional (stream *standard-input*))
(loop
with table = (make-hash-table) ; the hash table
with sentinel = (cons 1 1) ; unique value for EOF
for x = (read stream nil sentinel nil) ; read value, sentinel if EOF
until (eq sentinel x) ; until EOF, indicated by sentinel
do (setf (gethash (first x) table) (second x)) ; set a value in the table
finally (return table))) ; finally return the table
Then you can use it like this:
(with-open-file (in ".../input.txt")
(read-hashtable in))
;=> #<HASH-TABLE :TEST EQL :COUNT 2 {10056B2C43}>
If you're averse to loop, it's easy to do this with do, as well:
(defun read-hashtable (&optional (stream *standard-input*))
(do* ((sentinel (cons 1 1))
(table (make-hash-table))
(x (read stream nil sentinel nil) (read stream nil sentinel nil)))
((eq x sentinel) table)
(setf (gethash (first x) table) (second x))))
I managed to solve the problem using the following code:
(defun symbols-to-lowercase-strings (sym-list)
(let ((newlist (list '())))
(loop for symbol in sym-list
do (progn
(setf symbol (string symbol))
(setf symbol (string-downcase symbol))
(push symbol newlist)))
(subseq newlist 0 (- (length newlist) 1))))
(defun read-file (filename)
(let ((classes (make-hash-table :test #'equal))
(class-lists NIL))
(with-open-file (stream filename :direction :input)
(loop
for line = (read stream nil)
while line
collect line
do (push (cons (car line) (cdr line)) class-lists))
(loop for line in class-lists
do (setf (gethash (car line) classes) (list (symbols-to-lowercase-strings (car (cdr line))) '(0)))))
classes))
For example, here are two versions of function to count the instances of "a" in a region or in a string:
(defun foo (beg end)
(interactive "r")
(let ((count 0))
(save-excursion
(while (/= (point) end)
(if (equal (char-after) ?a)
(setq count (1+ count)))
(forward-char)))
count))
(defun foo1 (str)
(let ((count 0))
(mapcar #'(lambda (x) (if (equal x ?a) (setq count (1+ count))))
str)
count))
This is the test to check the function foo1:
(require 'ert)
(ert-deftest foo-test ()
(should (equal (foo1 "aba") 2)))
but how can I test the function foo that takes a region as input, using ert framework of unit testing?
I would second #sds's suggestion, with the added suggestion to do something like:
(with-temp-buffer
(insert <text>)
(set-mark <markpos>)
(goto-char <otherend>)
(should (equal (call-interactively 'foo) <n>)))
I would do something like this:
(with-temp-buffer
(insert ....) ; prepare the buffer
(should (equal ... (foo (point-min) (point-max)))))
I previously asked a question concerning message passing Abstraction here: MIT Scheme Message Passing Abstraction
The question asked that I:
Write a mailman object factory (make-mailman) that takes in no parameters and returns
a message-passing object that responds to the following messages:
'add-to-route: return a procedure that takes in an arbitrary number of mailbox objects
and adds them to the mailman object's “route”
'collect-letters: return a procedure that takes in an arbitrary number of letter
objects and collects them for future distribution
'distribute: add each of the collected letters to the mailbox on the mailman's route
whose address matches the letter's destination and return a list of any letters whose
destinations did not match any mailboxes on the route (Note: After each passing of
'distribute the mailman object should have no collected letters.)
I had already written 2 procedures earlier as part of this assignment to make a mailbox and make a letter:
(define (make-letter destination message)
(define (dispatch x)
(cond ((eq? x 'get-destination) destination)
((eq? x 'get-message) message)
(else "Invalid option.")))
dispatch)
(define (make-mailbox address)
(let ((T '()))
(define (post letter)
(assoc letter T))
(define (previous-post post)
(if (null? (cdr post)) post (cdr (previous-post post))))
(define (letter-in-mailbox? letter)
(if (member (post letter) T) #t #f))
(define (add-post letter)
(begin (set! T (cons letter T)) 'done))
(define (get-previous-post post)
(if (letter-in-mailbox? post)
(previous-post post)
#f))
(define (dispatch y)
(cond ((eq? y 'add-letter) add-post)
((eq? y 'get-latest-message) (get-previous-post T))
((eq? y 'get-address) address)
(else "Invalid option.")))
dispatch))
After being given a very good explanation on what my current answer was doing wrong and making many necessary changes to my code, I was told that any problems I have in that code would be better off asked in this question. Therefore, here is the code that builds off my previous question:
(define (make-mailman)
(let ((self (list '(ROUTE) '(MAILBAG))))
(define (add-to-route . mailboxes)
(let ((route (assoc 'ROUTE self)))
(set-cdr! route (append mailboxes (cdr route)))
'DONE))
(define (collect-letters . letters)
(let ((mailbag (assoc 'MAILBAG self)))
(set-cdr! mailbag (append letters (cdr mailbag)))
'DONE))
(define (distribute-the-letters)
(let* ((mailbag (assoc 'MAILBAG self))
(mailboxes (cdr (assoc 'ROUTE self)))
(letters (cdr mailbag)))
(if (null? letters)
()
(let loop ((letter (car letters))
(letters (cdr letters))
(not-delivered ()))
(let* ((address (letter 'get-address))
(mbx (find-mailbox address mailboxes)))
(if (equal? address letter)
((mbx 'add-post) letter)
((mbx 'add-post) not-delivered))
(if (null? letters)
(begin (set-cdr! mailbag '()) not-delivered)
(loop (car letters) (cdr letters) not-delivered)))))))
(define (dispatch z)
(cond ((eq? z 'add-to-route) add-to-route)
((eq? z 'collect-letters) collect-letters)
((eq? z 'distribute) distribute-the-letters)
(else "Invalid option")))
dispatch))
Essentially, I'm running into a different error now that instead returns that the distribute-the-letters procedure is being passed as an argument to length, which is not a list. I do not know why this error is being returned, since I would think that I am passing in the lists as they are needed. Would anyone be able to shed some light on what's going on? Any help will be appreciated.
UPDATE: Using this procedure in my make-mailman code now:
(define (find-mailbox address mailbox)
(if (not (element? address self))
#f
(if (element? mailbox self)
mailbox
#f)))
Your error is here:
(define (distribute-the-letters)
(let* ((mailbag (assoc 'MAILBAG self))
(mailboxes (cdr (assoc 'ROUTE self)))
(letters (cdr mailbag)))
(if (null? letters)
()
(let loop ((letter (car letters))
(letters (cdr letters))
(not-delivered ()))
(let* ((address (letter 'get-address))
(mbx (find-mailbox address mailboxes))) ;; has to be impl'd
;; (if (equal? address letter) ;; this makes
;; ((mbx 'add-post) letter) ;; no
;; ((mbx 'add-post) not-delivered)) ;; sense
;; here you're supposed to put the letter into the matching mailbox
;; or else - into the not-delivered list
(if mbox ;; NB! find-mailbox should accommodate this
((mbox 'put-letter) letter) ;; NB! "mailbox" should accom'te this
(set! not-delivered ;; else, it wasn't delivered
(cons letter not-delivered)))
(if (null? letters)
(begin
(set-cdr! mailbag '()) ;; the mailbag is now empty
not-delivered) ;; the final return
(loop (car letters)
(cdr letters)
not-delivered)))))))
find-mailbox still has to be implemented here. It should search for the matching mailbox, and return #f in case it is not found, or return the mailbox object itself if it was found. The "mailbox" objects must be able to respond to 'put-letter messages and have "addresses". The "letter" objects must also have "addresses" (which we retrieve with the call (letter 'get-address), and for mailbox we'd call (mbox 'get-address)), and these addresses must be so that we can compare them for equality.
That means that letters and mailboxes should be objects defined through the same kind of procedure as here the mailman is defined, with internal procedures, and the dispatch procedure exported as the object itself.
This all needs to be further implemented, or perhaps you have them already as part of some previous assignment?
now that you've provided your additional definitions, let's see.
make-letter seems OK. A letter supports two messages: 'get-destination and get-message.
make-mailbox has issues.
(define (make-mailbox address)
(let ((T '()))
(define (post letter)
(assoc letter T)) ;; why assoc? you add it with plain CONS
(define (previous-post post)
(if (null? (cdr post)) ;; post == T (11)
post
(cdr (previous-post post) ;; did you mean (prev-p (cdr post)) ? (12)
)))
(define (letter-in-mailbox? letter) ;; letter == T ??????? (3)
(if (member (post letter) T) #t #f))
(define (add-post letter)
(begin (set! T (cons letter T)) 'done)) ;; added with plain CONS
(define (get-previous-post post)
(if (letter-in-mailbox? post) ;; post == T (2)
(previous-post post) ;; post == T (10)
#f))
(define (dispatch y)
(cond ((eq? y 'add-letter) add-post)
((eq? y 'get-latest-message)
(get-previous-post T)) ;; called w/ T (1)
((eq? y 'get-address) address)
(else "Invalid option.")))
dispatch))
you add letters with add-post, and it calls (set! T (cons letter T)). So it adds each letter into the T list as-is. No need to use assoc to retrieve it later, it's just an element in a list. Just call (member letter T) to find out whether it's in. post has no function to perform, it should be (define (post letter) letter).
(if (member letter T) #t #f) is functionally the same as just (member letter T). In Scheme, any non-false value is like a #t.
Your previous-post (if fixed w/ (12) ) returns the last cdr cell of its argument list. If it holds letters (a b c d), (previous-post T) returns (d). Didn't you mean it to be a ? The message it handles is called 'get-latest-message after all. Whatever you just added with cons into list ls, can be gotten back with one simple call to ... (what?).
And why is it called get-latest-message? Does it return a letter, or the message within that letter? (and here the word message is used in two completely unrelated senses in one program; better call letter's contents, maybe, letter-contents ??
Lastly, we call (find-mailbox address mailboxes) in the main program, but you define (define (find-mailbox address mailbox) .... It should compare (equal? address (mailbox 'get-address)). self isn't needed, so this utility function can be put into global scope.
And it must enumerate through those mailboxes:
(define (find-mailbox address mailboxes)
(if (not (null? mailboxes))
(if (equal? address ((car mailboxes) 'get-address))
(car ..... )
(find-mailbox address .... ))))
I'm trying to do a list of pairs as a part of a homework assignment.
I tried doing (somewhere in the middle of a function)
(setq list1 (append list1 (cons n1 n2)))
And for some reason I don't understand, this works fine with the first pair, but as I try to append the second pair, this error pops up:
*** - APPEND: A proper list must not end with 2
How can I solve this?
So, continuing on this subject, thanks to the answer given, I was able to correct my problem. But a new one came up, and I think it is related with it. So, I have this function:
(defun action(state)
(let ((list_actions '())
(limNumActions (1- (list-length state)))
(limNumSubActions 0)
(numActions 0)
(numSubActions 0))
(loop for numActions from 0 to limNumActions do
(setq limNumSubActions (1- (list-length (nth numActions state))))
(loop for numSubActions from 0 to limNumSubActions do
(setq list_actions (append list_actions
(list (cons numActions numSubActions))))
(print 'list_actions)
(print list_actions)))))
I used the printfunction as a simple "debugger". It returns this:
LIST_ACTIONS
((0 . 0))
LIST_ACTIONS
((0 . 0) (0 . 1))
LIST_ACTIONS
((0 . 0) (0 . 1) (1 . 0))
LIST_ACTIONS
((0 . 0) (0 . 1) (1 . 0) (1 . 1))
NIL
And this is exactly the result I was expecting! Except for the NIL part... Can you understand why the list list_actions is NILat the end?
The code can be expressed more succintly as follows:
(defun action (state)
(let ((list-actions '()))
(loop for i from 0 for state-i in state do
(loop for j from 0 below (length state-i) do
(setf list-actions (append list-actions (list (cons i j))))
(print 'list-actions)
(print list-actions)))
list-actions))
If only the result is needed, it can be shorter (and less costly, because it doesn't use the expensive append function),
(defun action (state)
(loop for i from 0 for state-i in state append
(loop for j below (length state-i) collect (cons i j))))
append takes two lists, not a list and a single element. You need to put a list around the pair before using it in append.
Currently the pair is being taken as part of the list, which makes the list improper and causes the second append to fail since improper lists don't exactly have an end to append to.
I have tried to refine your example a bit + write a version which uses a different, but, IMO more idiomatic approach to the problem:
;; Your original version, but cleaned up a bit
(defun action (state)
(loop with list-actions = nil
with lim-num-actions = (1- (list-length state))
with lim-num-sub-actions = 0
for num-actions from 0 to lim-num-actions
do (setq lim-num-sub-actions (1- (list-length (nth num-actions state))))
(loop for num-sub-actions from 0 to lim-num-sub-actions
do (push (cons num-actions num-sub-actions) list-actions)
(format t "~&~s ~s" 'list-actions list-actions))
finally (return list-actions)))
;; A more traditional approach (if you want to use iteration)
(defun action (state)
(reverse
(loop for i in state
for j from 0
collect (cons j 0))))
;; Using a nice library to do iteration
(ql:quickload "iterate")
;; Note, you could do (in-package :iterate)
;; to lose `iterate:' prefix to make it even shorter
(defun action (state)
(iterate:iter
(iterate:for i #:on state)
(iterate:for j #:from 0)
(iterate:accumulate (cons j 0) #:by #'cons)))
;; Just another way to do this, using `reduce'
(reduce #'(lambda (a b)
(declare (ignore b))
(cons (cons (1+ (caar a)) 0) a))
(cdr (mapcar #'list '(1 2 3 4 5)))
:initial-value '((0 . 0)))
(action (mapcar #'list '(1 2 3 4 5)))