The goal is to create a function that accepts a list of symbols and produces a list of key value pairs that count how many times each symbol in list appears. eg:
(counter (list 't 't 'c 'a)) -> (list (list 't 2) (list 'c 1) (list 'a 1))
The function must be completed with recursion
I've only gotten as far as to create a list of key value pairs that treat duplicates as standalone values:
(define val 0)
(define (counter los)
(cond
[(empty? los) empty]
[else (cons (list (first los) (add1 val))
(counter (rest los)))]))
(counter (list 't 't 'c 'a)) -> (list (list 't) (list 't) (list 'c 1) (list 'a 1))
It has been a very long time since I used BSL but I believe these operations are all present. There may be a cleaner way of doing this but I will leave it up to you to check the documentation and simplify it if possible
(define (counter los) (counter-helper los empty))
(define (counter-helper los lists)
(cond
[(empty? los) lists]
[else (if (list? (assq (first los) lists))
(counter-helper
(rest los)
(cons (list (first los) (add1 (second (assq (first los) lists))))
(remove (assq (first los) lists) lists)))
(counter-helper (rest los) (cons (list (first los) 1) lists)))]))
the if statement checks if there is already an entry in our list of lists for that key, it returns the pair if yes, false otherwise.
If the result is false we just append a new pair with value 1 and recur.
If it already exists, we construct a new pair from the previous one, with the same key, but the value incremented and append this new pair to our list of lists - the previous pair removed
I am having the following trouble: when trying to use APPLY function with a MAPCAR call, the lambda function passed to APPLY, which contains only one parameter, the list returned by MAPCAR, gives the following error :
*** - EVAL/APPLY: too many arguments given to :LAMBDA
The following code identifies if a heterogenous list has the last atom at any level a numerical atom.
(DEFUN hasLastNumeric (L)
(COND
((NUMBERP L) T)
((ATOM L) NIL)
((LISTP L)
(APPLY #'(LAMBDA (Lst)
(COND ((EQ (LAST Lst) T) T)
(T NIL)))
(MAPCAR 'hasLastNumeric L)))))
(WRITE (hasLastNumeric '(1 2 5)))
You don't need APPLY. Why would you use it? Remember: APPLY calls a function and uses the provided list as the list of arguments.
MAPCAR returns a list.
(let ((foo (mapcar #'1+ '(1 2 3 4))))
(cond ((eql (last foo) ...) ...)
...))
Check also what last actually returns...
If you call a function eg. (#'(lambda (a b) (+ a b)) 2 3) there is a requirement that the number of arguments fits the number of provided arguments. When using apply the requirements are the same so (apply #'(lambda (one) ...) lst) require that lst is only one element list like '(a), but it cannot be '() or '(a b). The only way to support variable number of arguments you need to use &rest arguments eg. (apply #'(lambda (&rest lst) ...) '(a b))
Looking at the logic I don't understand it. You want to return t when you have encountered a list with the last element as a number but also searched list elements on the way and returned early had you found them. It should be possible without the use of last at each step. eg.
(defun has-a-last-numeric (lst)
(labels ((helper (lst)
(loop :for (e . rest) :on lst
:if (and (null rest) (numberp e))
:do (return-from has-a-last-numeric t)
:if (listp e)
:do (helper e))))
(helper lst)))
I'm new to lisp, and have been trying to learn Common Lisp by diving in and writing some code. I've read plenty of documentation on the subject, but it's taking a while to really sink in.
I have written a couple of macros (? and ??) for performing unit tests, but I'm having some difficulty. The code is at the end of the post, to avoid cluttering the actual question.
Here is an example of usage:
(??
(? "Arithmetic tests"
(? "Addition"
(= (+ 1 2) 3)
(= (+ 1 2 3) 6)
(= (+ -1 -3) -4))))
And an example of output:
[Arithmetic tests]
[Addition]
(PASS) '(= (+ 1 2) 3)'
(PASS) '(= (+ 1 2 3) 6)'
(PASS) '(= (+ -1 -3) -4)'
Results: 3 tests passed, 0 tests failed
Now, the existing code works. Unfortunately, the (? ...) macro is ugly, verbose, resistant to change - and I'm pretty sure also badly structured. For example, do I really have to use a list to store pieces of output code and then emit the contents at the end?
I'd like to modify the macro to permit description strings (or symbols) to optionally follow each test, whereupon it would replace the test literal in the output, thus:
(??
(? "Arithmetic tests"
(? "Addition"
(= (+ 1 2) 3) "Adding 1 and 2 results in 3"
(= (+ 1 2 3) 6)
(= (+ -1 -3) -4))))
Output:
[Arithmetic tests]
[Addition]
(PASS) Adding 1 and 2 results in 3
(PASS) '(= (+ 1 2 3) 6)'
(PASS) '(= (+ -1 -3) -4)'
But unfortunately I can't find a sensible place in the macro to insert this change. Depending on where I put it, I get errors like you're not inside a backquote expression, label is not defined or body-forms is not defined. I know what these errors mean, but I can't find a way to avoid them.
Also, I'll be wanting to handle exceptions in the test, and treat that as a failure. Currently, there is no exception handling code - the test result is merely tested against nil. Again, it is not clear how I should add this functionality.
I'm thinking that maybe this macro is over-complex, due to my inexperience in writing macros; and perhaps if I simplify it, modification will be easier. I don't really want to separate it out into several smaller macros without good reason; but maybe there's a terser way to write it?
Can anyone help me out here, please?
A complete code listing follows:
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (gensym)))
,#body))
(defmacro while (condition &body body)
`(loop while ,condition do (progn ,#body)))
(defun flatten (L)
"Converts a list to single level."
(if (null L)
nil
(if (atom (first L))
(cons (first L) (flatten (rest L)))
(append (flatten (first L)) (flatten (rest L))))))
(defun starts-with-p (str1 str2)
"Determine whether `str1` starts with `str2`"
(let ((p (search str2 str1)))
(and p (= 0 p))))
(defmacro pop-first-char (string)
`(with-gensyms (c)
(if (> (length ,string) 0)
(progn
(setf c (schar ,string 0))
(if (> (length ,string) 1)
(setf ,string (subseq ,string 1))
(setf ,string ""))))
c))
(defmacro pop-chars (string count)
`(with-gensyms (result)
(setf result ())
(dotimes (index ,count)
(push (pop-first-char ,string) result))
result))
(defun format-ansi-codes (text)
(let ((result ()))
(while (> (length text) 0)
(cond
((starts-with-p text "\\e")
(push (code-char #o33) result)
(pop-chars text 2)
)
((starts-with-p text "\\r")
(push (code-char 13) result)
(pop-chars text 2)
)
(t (push (pop-first-char text) result))
))
(setf result (nreverse result))
(coerce result 'string)))
(defun kv-lookup (values key)
"Like getf, but works with 'keys as well as :keys, in both the list and the supplied key"
(setf key (if (typep key 'cons) (nth 1 key) key))
(while values
(let ((k (pop values)) (v (pop values)))
(setf k (if (typep k 'cons) (nth 1 k) k))
(if (eql (symbol-name key) (symbol-name k))
(return v)))))
(defun make-ansi-escape (ansi-name)
(let ((ansi-codes '( :normal "\\e[00m" :white "\\e[1;37m" :light-grey "\\e[0;37m" :dark-grey "\\e[1;30m"
:red "\\e[0;31m" :light-red "\\e[1;31m" :green "\\e[0;32m" :blue "\\e[1;34m" :dark-blue "\\e[1;34m"
:cyan "\\e[1;36m" :magenta "\\e[1;35m" :yellow "\\e[0;33m"
:bg-dark-grey "\\e[100m"
:bold "\\e[1m" :underline "\\e[4m"
:start-of-line "\\r" :clear-line "\\e[2K" :move-up "\\e[1A")))
(format-ansi-codes (kv-lookup ansi-codes ansi-name))
))
(defun format-ansi-escaped-arg (out-stream arg)
(cond
((typep arg 'symbol) (format out-stream "~a" (make-ansi-escape arg)))
((typep arg 'string) (format out-stream arg))
(t (format out-stream "~a" arg))
))
(defun format-ansi-escaped (out-stream &rest args)
(while args
(let ((arg (pop args)))
(if (typep arg 'list)
(let ((first-arg (eval (first arg))))
(format out-stream first-arg (second arg))
)
(format-ansi-escaped-arg out-stream arg)
))
))
(defmacro while-pop ((var sequence &optional result-form) &rest forms)
(with-gensyms (seq)
`(let (,var)
(progn
(do () ((not ,sequence))
(setf ,var (pop ,sequence))
(progn ,#forms))
,result-form))))
(defun report-start (form)
(format t "( ) '~a'~%" form))
(defun report-result (result form)
(format-ansi-escaped t "(" (if result :green :red) `("~:[FAIL~;PASS~]" ,result) :normal `(") '~a'~%" ,form))
result)
(defmacro ? (name &body body-forms)
"Run any number of test forms, optionally nested within further (?) calls, and print the results of each test"
(with-gensyms (result indent indent-string)
(if (not body-forms)
:empty
(progn
(setf result () indent 0 indent-string " ")
(cond
((typep (first body-forms) 'integer)
(setf indent (pop body-forms))))
`(progn
(format t "~v#{~A~:*~}" ,indent ,indent-string)
(format-ansi-escaped t "[" :white ,name :normal "]~%")
(with-gensyms (test-results)
(setf test-results ())
,(while-pop (body-form body-forms `(progn ,#(nreverse result)))
(cond
( (EQL (first body-form) '?)
(push `(progn
(setf test-results (append test-results (? ',(nth 1 body-form) ,(1+ indent) ,#(nthcdr 2 body-form))))
(format t "~%")
test-results
) result)
)
(t
(push `(progn
(format t "~v#{~A~:*~}" ,(1+ indent) ,indent-string)
(report-start ',body-form)
(with-gensyms (result label)
(setf result ,body-form)
(format-ansi-escaped t :move-up :start-of-line :clear-line)
(format t "~v#{~A~:*~}" ,(1+ indent) ,indent-string)
(push (report-result result ',body-form) test-results)
test-results
)) result))))))))))
(defun ?? (&rest results)
"Run any number of tests, and print a summary afterward"
(setf results (flatten results))
(format-ansi-escaped t "~&" :white "Results: " :green `("~a test~:p passed" ,(count t results)) :normal ", "
(if (find NIL results) :red :normal) `("~a test~:p failed" ,(count NIL results))
:yellow `("~[~:;, ~:*~a test~:p not run~]" ,(count :skip results))
:brown `("~[~:;, ~:*~a empty test group~:p skipped~]" ,(count :empty results))
:normal "~%"))
For my part, the ? macro is rather technical and it's hard to follow the logic behind the formatting functions. So instead of tracking errors I'd like to suggest my own attempt, perhaps it'll be of use.
I think that actually your ?? doesn't want to evaluate anything, but rather to treat its body as individual tests or sections. If the body includes a list starting with ?, this list represents a section; other elements are test forms optionally followed by descriptions. So in my implementation ?? will be a macro, and ? will be just a symbol.
I start with wishful thinking. I suppose I can create individual tests using a function make-test-item and test sections using a function make-test-section (their implementation is unimportant for now), that I can display them using an auxiliary function display-test and compute results using the function results, which returns two values: the total number of tests and the number of passed ones. Then I'd like the code
(??
(? "Arithmetic tests"
(? "Addition"
(= (+ 1 2) 3) "Adding 1 and 2 results in 3"
(= (+ 1 2 3) 6)
(= (+ -1 -3) 4))
(? "Subtraction"
(= (- 1 2) 1)))
(= (sin 0) 0) "Sine of 0 equals 0")
to expand into something like
(let ((tests (list (make-test-section :header "Arithmetic tests"
:items (list (make-test-section :header "Addition"
:items (list (make-test-item :form '(= (+ 1 2) 3)
:description "Adding 1 and 2 results in 3"
:passp (= (+ 1 2) 3))
(make-test-item :form '(= (+ 1 2 3) 6)
:passp (= (+ 1 2 3) 6))
(make-test-item :form '(= (+ -1 -3) 4)
:passp (= (+ -1 -3) 4))))
(make-test-section :header "Subtraction"
:items (list (make-test-item :form '(= (- 1 2) 1)
:passp (= (- 1 2) 1))))))
(make-test-item :form '(= (sin 0) 0)
:passp (= (sin 0) 0)
:description "Sine of 0 equals 0"))))
(loop for test in tests
with total = 0
with passed = 0
do (display-test test 0 t)
do (multiple-value-bind (ttl p) (results test)
(incf total ttl)
(incf passed p))
finally (display-result total passed t)))
Here a list of tests is created; then we traverse it printing each test (0 denotes the zero level of indentation and t is as in format) and keeping track of the results, finally displaying the total results. I don't think explicit eval is needed here.
It may not be the most exquisite piece of code ever, but it seems manageable. I supply missing definitions below, they are rather trivial (and can be improved) and have nothing to do with macros.
Now we pass on to the macros. Consider both pieces of code as data, then we want a list processing function which would turn the first one into the second. A few auxiliary functions would come in handy.
The major task is to parse the body of ?? and generate the list of test to go inside the let.
(defun test-item-form (form description)
`(make-test-item :form ',form :description ,description :passp ,form))
(defun test-section-form (header items)
`(make-test-section :header ,header :items (list ,#items)))
(defun parse-test (forms)
(let (new-forms)
(loop
(when (null forms)
(return (nreverse new-forms)))
(let ((f (pop forms)))
(cond ((and (listp f) (eq (first f) '?))
(push (test-section-form (second f) (parse-test (nthcdr 2 f))) new-forms))
((stringp (first forms))
(push (test-item-form f (pop forms)) new-forms))
(t (push (test-item-form f nil) new-forms)))))))
Here parse-test essentially absorbs the syntax of ??. Each iteration consumes one or two forms and collects corresponding make-... forms. The functions can be easily tested in REPL (and, of course, I did test them while writing).
Now the macro becomes quite simple:
(defmacro ?? (&body body)
`(let ((tests (list ,#(parse-test body))))
(loop for test in tests
with total = 0
with passed = 0
do (display-test test 0 t)
do (multiple-value-bind (ttl p) (results test)
(incf total ttl)
(incf passed p))
finally (display-result total passed t))))
It captures a few symbols, both in the variable name space and in the function one (the expansion may contain make-test-item and make-test-section). A clean solution with gensyms would be cumbersome, so I'd suggest just moving all the definitions in a separate package and exporting only ?? and ?.
For completeness, here is an implementation of the test API. Actually, it's what I started coding with and proceeded until I made sure the big let-form works; then I passed on to the macro part. This implementation is fairly sloppy; in particular, it doesn't support terminal colours and display-test can't even output a section into a string.
(defstruct test-item form description passp)
(defstruct test-section header items)
(defun results (test)
(etypecase test
(test-item (if (test-item-passp test)
(values 1 1)
(values 1 0)))
(test-section (let ((items-count 0)
(passed-count 0))
(dolist (i (test-section-items test) (values items-count passed-count))
(multiple-value-bind (i p) (results i)
(incf items-count i)
(incf passed-count p)))))))
(defparameter *test-indent* 2)
(defun display-test-item (i level stream)
(format stream "~V,0T~:[(FAIL)~;(PASS)~] ~:['~S'~;~:*~A~]~%"
(* level *test-indent*)
(test-item-passp i)
(test-item-description i)
(test-item-form i)))
(defun display-test-section-header (s level stream)
(format stream "~V,0T[~A]~%"
(* level *test-indent*)
(test-section-header s)))
(defun display-test (test level stream)
(etypecase test
(test-item (display-test-item test level stream))
(test-section
(display-test-section-header test level stream)
(dolist (i (test-section-items test))
(display-test i (1+ level) stream)))))
(defun display-result (total passed stream)
(format stream "Results: ~D test~:P passed, ~D test~:P failed.~%" passed (- total passed)))
All the code is licenced under WTFPL.
I have a series of expressions to convert from postfix to prefix and I thought that I would try to write a program to do it for me in DrRacket. I am getting stuck with some of the more complex ones such as (10 (1 2 3 +) ^).
I have the very simple case down for (1 2 \*) → (\* 1 2). I have set these expressions up as a list and I know that you have to use cdr/car and recursion to do it but that is where I get stuck.
My inputs will be something along the lines of '(1 2 +).
I have for simple things such as '(1 2 +):
(define ans '())
(define (post-pre lst)
(set! ans (list (last lst) (first lst) (second lst))))
For the more complex stuff I have this (which fails to work correctly):
(define ans '())
(define (post-pre-comp lst)
(cond [(pair? (car lst)) (post-pre-comp (car lst))]
[(pair? (cdr lst)) (post-pre-comp (cdr lst))]
[else (set! ans (list (last lst) (first lst) (second lst)))]))
Obviously I am getting tripped up because (cdr lst) will return a pair most of the time. I'm guessing my structure of the else statement is wrong and I need it to be cons instead of list, but I'm not sure how to get that to work properly in this case.
Were you thinking of something like this?
(define (pp sxp)
(cond
((null? sxp) sxp)
((list? sxp) (let-values (((args op) (split-at-right sxp 1)))
(cons (car op) (map pp args))))
(else sxp)))
then
> (pp '(1 2 *))
'(* 1 2)
> (pp '(10 (1 2 3 +) ^))
'(^ 10 (+ 1 2 3))
Try something like this:
(define (postfix->prefix expr)
(cond
[(and (list? expr) (not (null? expr)))
(define op (last expr))
(define args (drop-right expr 1))
(cons op (map postfix->prefix args))]
[else expr]))
This operates on the structure recursively by using map to call itself on the arguments to each call.
I wonder if it's possible to write a macro in Racket that would translate every form of shape (c(a|d)+r xs), where c(a|d)+r is a regular expression matching car, cdr, caar, cadr, ... etc, into
the corresponding composition of first and rest.
For example, this macro should take (caadr '(1 2 3 4 5)) and transform that to (first (first (rest '(1 2 3 4 5)))).
Something like this in Shen (Mark Tarver's new programming language): https://groups.google.com/group/qilang/browse_thread/thread/131eda1cf60d9094?hl=en
It is very possible to do exactly that in Racket, and in a much shorter way than done above. There are two (not-really) tricks involved:
Using Racket's #%top macro makes it possible to create such bindings-out-of-thin-air. This macro is getting used implicitly around any variable reference that is unbound ("top" because these things are references to toplevel variables).
Macros become much simpler if you make them do the necessary minimum, and leave the rest to a function.
Here's the complete code with comments and tests (the actual code is tiny, ~10 lines).
#lang racket
;; we're going to define our own #%top, so make the real one available
(require (only-in racket [#%top real-top]))
;; in case you want to use this thing as a library for other code
(provide #%top)
;; non-trick#1: doing the real work in a function is almost trivial
(define (c...r path)
(apply compose (map (λ(x) (case x [(#\a) car] [(#\d) cdr])) path)))
;; non-trick#2: define our own #%top, which expands to the above in
;; case of a `c[ad]*r', or to the real `#%top' otherwise.
(define-syntax (#%top stx)
(syntax-case stx ()
[(_ . id)
(let ([m (regexp-match #rx"^c([ad]*)r$"
(symbol->string (syntax-e #'id)))])
(if m
#`(c...r '#,(string->list (cadr m)))
#'(real-top . id)))]))
;; Tests, to see that it works:
(caadadr '(1 (2 (3 4)) 5 6))
(let ([f caadadr]) (f '(1 (2 (3 4)) 5 6))) ; works even as a value
(cr 'bleh)
(cadr '(1 2 3)) ; uses the actual `cadr' since it's bound,
;; (cadr '(1)) ; to see this, note this error message
;; (caddddr '(1)) ; versus the error in this case
(let ([cr list]) (cr 'bleh)) ; lexical scope is still respected
You can certainly write something that takes in a quoted s-expression and outputs the translation as a quoted s-expression.
Start with simply translating well-formed lists like '(#\c #\a #\d #\r) into your first/rest s-expressions.
Now build the solution with symbol?, symbol->string, regexp-match #rx"^c(a|d)+r$", string->list, and map
Traverse the input. If it is a symbol, check the regexp (return as-is if it fails), convert to list, and use your starting translator. Recurse on the nested expressions.
EDIT: here's some badly written code that can translate source-to-source (assuming the purpose is to read the output)
;; translates a list of characters '(#\c #\a #\d #\r)
;; into first and rest equivalents
;; throw first of rst into call
(define (translate-list lst rst)
(cond [(null? lst) (raise #f)]
[(eq? #\c (first lst)) (translate-list (rest lst) rst)]
[(eq? #\r (first lst)) (first rst)]
[(eq? #\a (first lst)) (cons 'first (cons (translate-list (rest lst) rst) '()))]
[(eq? #\d (first lst)) (cons 'rest (cons (translate-list (rest lst) rst) '()))]
[else (raise #f)]))
;; translate the symbol to first/rest if it matches c(a|d)+r
;; pass through otherwise
(define (maybe-translate sym rst)
(if (regexp-match #rx"^c(a|d)+r$" (symbol->string sym))
(translate-list (string->list (symbol->string sym)) rst)
(cons sym rst)))
;; recursively first-restify a quoted s-expression
(define (translate-expression exp)
(cond [(null? exp) null]
[(symbol? (first exp)) (maybe-translate (first exp) (translate-expression (rest exp)))]
[(pair? (first exp)) (cons (translate-expression (first exp)) (translate-expression (rest exp)))]
[else exp]))
'test-2
(define test-2 '(cadr (1 2 3)))
(maybe-translate (first test-2) (rest test-2))
(translate-expression test-2)
(translate-expression '(car (cdar (list (list 1 2) 3))))
(translate-expression '(translate-list '() '(a b c)))
(translate-expression '(() (1 2)))
As mentioned in the comments, I am curious why you'd want a macro. If the purpose is to translate source into something readable, don't you want to capture the output to replace the original?
Let Over Lambda is a book which uses Common Lisp but it has a chapter in which it defines a macro with-all-cxrs that does what you want.
Here's my implementation (now fixed to use call-site's car and cdr, so you can redefine them and they will work correctly):
(define-syntax (biteme stx)
(define (id->string id)
(symbol->string (syntax->datum id)))
(define (decomp id)
(define match (regexp-match #rx"^c([ad])(.*)r$" (id->string id)))
(define func (case (string-ref (cadr match) 0)
((#\a) 'car)
((#\d) 'cdr)))
(datum->syntax id (list func (string->symbol (format "c~ar" (caddr match))))))
(syntax-case stx ()
((_ (c*r x)) (regexp-match #rx"^c[ad]+r$" (id->string #'c*r))
(with-syntax (((a d) (decomp #'c*r)))
(syntax-case #'d (cr)
(cr #'(a x))
(_ #'(a (biteme (d x)))))))))
Examples:
(biteme (car '(1 2 3 4 5 6 7))) ; => 1
(biteme (cadr '(1 2 3 4 5 6 7))) ; => 2
(biteme (cddddr '(1 2 3 4 5 6 7))) ; => (5 6 7)
(biteme (caddddddr '(1 2 3 4 5 6 7))) ; => 7
(let ((car cdr)
(cdr car))
(biteme (cdaaaaar '(1 2 3 4 5 6 7)))) ; => 6