Related
I just started to learn Common Lisp and this is my first functional programming language.
I am trying to learn about iterating through lists. I wrote these two functions:
(defun reverseList (liste)
(defvar reversedList(list))
(loop for i downfrom (-(length liste)1) to 0 do
(setf reversedList (append reversedList (list(nth i liste)))))
reversedList ;return
)
(defun countAppearance(liste element)
(defvar count 0)
(loop for i from 0 to (-(length liste) 1)do
(if (= (nth i liste) element)
(setf count (+ count 1))))
count
)
Both work fine for a regular list(ex: (1 3 5 7 3 9) but I want them to work for nested lists too.
Examples:
countAppearance - Input: (1 (3 5) (3 7 8) 2) 3 -> Expected output:2
reverseList - Input: (1 (2 3)) -> Expected output: ((3 2) 1)
Before I will show you solutions for nested lists, some notes about your code:
There is already function reverse for non-nested lists, so you don't have to reinvent the wheel.
=> (reverse (list 1 2 3 4 5))
(5 4 3 2 1)
If you need some local variables, use let or let*.
Lisp uses kebab-case, not camelCase, so rename reverseList as reverse-list and so on.
For (setf ... (+ ... 1)), use incf.
For iterating over list, use dolist.
Function count-occurrences can be written using recursion:
(defun count-occurrences (lst elem)
(cond ((null lst) 0)
((= (car lst) elem) (+ 1 (count-occurrences (cdr lst) elem)))
(t (count-occurrences (cdr lst) elem))))
CL-USER 3 > (count-occurrences (list 1 2 3 1 2 3) 2)
2
Or it can be written with let, dolist and incf:
(defun count-occurrences2 (lst elem)
(let ((count 0))
(dolist (e lst)
(when (= e elem) (incf count)))
count))
CL-USER 4 > (count-occurrences2 (list 1 2 3 1 2 3) 2)
2
Solutions for nested lists use recursion:
(defun deep-reverse (o)
(if (listp o)
(reverse (mapcar #'deep-reverse o))
o))
CL-USER 11 > (deep-reverse '(1 (2 3)))
((3 2) 1)
(defun deep-count (lst elem)
(cond ((null lst) 0)
((listp (car lst)) (+ (deep-count (car lst) elem)
(deep-count (cdr lst) elem)))
((= (car lst) elem) (+ 1 (deep-count (cdr lst) elem)))
(t (deep-count (cdr lst) elem))))
CL-USER 12 > (deep-count '(1 (3 5) (3 7 8) 2) 3)
2
Welcome to functional programming.
Firstly, there are some problems with the code that you have provided for us. There are some spaces missing from the code. Spaces are important because they separate one thing from another. The code (xy) is not the same as (x y).
Secondly, there is an important difference between local and global variables. So, in both cases, you want a local variable for reversedList and count. This is the tricky point. Common Lisp doesn't have global or local variables, it has dynamic and lexical variables, which aren't quite the same. For these purposes, we can use lexical variables, introduced with let. The keyword let is used for local variables in many functional languages. Also, defvar may not do what you expect, since it is way of writing a value once, which cannot be overwritten - I suspect that defparameter is what you meant.
Thirdly, looking at the reverse function, loop has its own way of gathering results into a list called collect. This would be a cleaner solution.
(defun my-reverse (lst)
(loop for x from (1- (length lst)) downto 0 collect (nth x lst)))
It can also be done in a tail recursive way.
(defun my-reverse-tail (lst &optional (result '()))
(if lst
(my-reverse-tail (rest lst) (cons (first lst) result))
result))
To get it to work with nested lists, before you collect or cons each value, you need to check if it is a list, using listp. If it is not a list, just add it onto the result. If it is a list, add on instead a call to your reverse function on the item.
Loop also has functionality to count items.
I'm trying to get the largest sublist from a list using Common Lisp.
(defun maxlist (list)
(setq maxlen (loop for x in list maximize (list-length x)))
(loop for x in list (when (equalp maxlen (list-length x)) (return-from maxlist x)))
)
The idea is to iterate through the list twice: the first loop gets the size of the largest sublist and the second one retrieves the required list. But for some reason I keep getting an error in the return-from line. What am I missing?
Main problem with loop
There are a few problems here. First, you can write the loop as the following. There are return-from and while forms in Common Lisp, but loop defines its own little language that also recognizes while and return, so you can just use those:
(loop for x in list
when (equalp maxlen (list-length x))
return x)
A loop like this can actually be written more concisely with find though. It's just
(find maxlen list :key list-length :test 'equalp)
Note, however, that list-length should always return a number or nil, so equalp is overkill. You can just use eql, and that's the default for find, so you can even write
(find maxlen list :key list-length)
list-length and maximize
list-length is a lot like length, except that if a list has circular structure, it returns nil, whereas it's an error to call length with an improper list. But if you're using (loop ... maximize ...), you can't have nil values, so the only case that list-length handles that length wouldn't is one that will still give you an error. E.g.,
CL-USER> (loop for x in '(4 3 nil) maximize x)
; Evaluation aborted on #<TYPE-ERROR expected-type: REAL datum: NIL>.
(Actually, length works with other types of sequences too, so list-length would error if you passed a vector, but length wouldn't.) So, if you know that they're all proper lists, you can just
(loop for x in list
maximizing (length x))
If they're not all necessarily proper lists (so that you do need list-length), then you need to guard like:
(loop for x in list
for len = (list-length x)
unless (null len) maximize len)
A more efficient argmax
However, right now you're making two passes over the list, and you're computing the length of each sublist twice. Once is when you compute the maximum length, and the other is when you go to find one with the maximum value. If you do this in one pass, you'll save time. argmax doesn't have an obvious elegant solution, but here are implementations based on reduce, loop, and do*.
(defun argmax (fn list &key (predicate '>) (key 'identity))
(destructuring-bind (first &rest rest) list
(car (reduce (lambda (maxxv x)
(destructuring-bind (maxx . maxv) maxxv
(declare (ignore maxx))
(let ((v (funcall fn (funcall key x))))
(if (funcall predicate v maxv)
(cons x v)
maxxv))))
rest
:initial-value (cons first (funcall fn (funcall key first)))))))
(defun argmax (function list &key (predicate '>) (key 'identity))
(loop
for x in list
for v = (funcall function (funcall key x))
for maxx = x then maxx
for maxv = v then maxv
when (funcall predicate v maxv)
do (setq maxx x
maxv v)
finally (return maxx)))
(defun argmax (function list &key (predicate '>) (key 'identity))
(do* ((x (pop list)
(pop list))
(v (funcall function (funcall key x))
(funcall function (funcall key x)))
(maxx x)
(maxv v))
((endp list) maxx)
(when (funcall predicate v maxv)
(setq maxx x
maxv v))))
They produce the same results:
CL-USER> (argmax 'length '((1 2 3) (4 5) (6 7 8 9)))
(6 7 8 9)
CL-USER> (argmax 'length '((1 2 3) (6 7 8 9) (4 5)))
(6 7 8 9)
CL-USER> (argmax 'length '((6 7 8 9) (1 2 3) (4 5)))
(6 7 8 9)
Short variant
CL-USER> (defparameter *test* '((1 2 3) (4 5) (6 7 8 9)))
*TEST*
CL-USER> (car (sort *test* '> :key #'length))
(6 7 8 9)
Paul Graham's most
Please, consider also Paul Graham's most function:
(defun most (fn lst)
(if (null lst)
(values nil nil)
(let* ((wins (car lst))
(max (funcall fn wins)))
(dolist (obj (cdr lst))
(let ((score (funcall fn obj)))
(when (> score max)
(setq wins obj
max score))))
(values wins max))))
This is the result of test (it also returns value that's returned by supplied function for the 'best' element):
CL-USER> (most #'length *test*)
(6 7 8 9)
4
extreme utility
After a while I came up with idea of extreme utility, partly based on Paul Graham's functions. It's efficient and pretty universal:
(declaim (inline use-key))
(defun use-key (key arg)
(if key (funcall key arg) arg))
(defun extreme (fn lst &key key)
(let* ((win (car lst))
(rec (use-key key win)))
(dolist (obj (cdr lst))
(let ((test (use-key key obj)))
(when (funcall fn test rec)
(setq win obj rec test))))
(values win rec)))
It takes comparison predicate fn, list of elements and (optionally) key parameter. Object with the extreme value of specified quality can be easily found:
CL-USER> (extreme #'> '(4 9 2 1 5 6))
9
9
CL-USER> (extreme #'< '(4 9 2 1 5 6))
1
1
CL-USER> (extreme #'> '((1 2 3) (4 5) (6 7 8 9)) :key #'length)
(6 7 8 9)
4
CL-USER> (extreme #'> '((1 2 3) (4 5) (6 7 8 9)) :key #'cadr)
(6 7 8 9)
7
Note that this thing is called extremum in alexandria. It can work with sequences too.
Using recursion:
(defun maxim-list (l)
(flet ((max-list (a b) (if (> (length a) (length b)) a b)))
(if (null l)
nil
(max-list (car l) (maxim-list (cdr l))))))
The max-list internal function gets the longest of two list. maxim-list is getting the longest of the first list and the maxim-list of the rest.
How to calculate the difference between two sets in Emacs Lisp? The sets should be lists.
The programm should be very simple and short, or else I won't understand it. I'm a newbee.
Thx
There is a set-difference function in the Common Lisp extensions:
elisp> (require 'cl-lib)
cl-lib
elisp> (cl-set-difference '(1 2 3) '(2 3 4))
(1)
When I write Elisp code that has lots of list data transformations, I use dash library, because it has loads of functions to work with lists. Set difference can be done with -difference:
(require 'dash)
(-difference '(1 2 3 4) '(3 4 5 6)) ;; => '(1 2)
Disclaimer: this is not an efficient way to do it in eLisp. An efficient way is through a hash-table with a hash function, but since you asked about lists, then here it is:
(defun custom-set-difference (a b)
(remove-if
#'(lambda (x) (and (member x a) (member x b)))
(append a b)))
(custom-set-difference '(1 2 3 4 5) '(2 4 6))
(1 3 5 6)
(defun another-set-difference (a b)
(if (null a) b
(let (removed)
(labels ((find-and-remove
(c)
(cond
((null c) nil)
((equal (car c) (car a))
(setq removed t) (cdr c))
(t (cons (car c) (find-and-remove (cdr c)))))))
(setf b (find-and-remove b))
(if removed
(another-set-difference (cdr a) b)
(cons (car a) (another-set-difference (cdr a) b)))))))
(another-set-difference '(1 2 3 4 5) '(2 4 6))
(1 3 5 6)
The second is slightly more efficient, because it will remove the elements as it makes consequent checks, but the first is shorter and more straight-forward.
Also note that lists are not good representation of sets because they naturally allow repetition. Hash maps are better for that purpose.
Here is a simple & short definition, which should be easy to understand. It is essentially the same as the set-difference function in the Common Lisp library for Emacs, but without any treatment of a TEST argument.
(defun set-diff (list1 list2 &optional key)
"Combine LIST1 and LIST2 using a set-difference operation.
Optional arg KEY is a function used to extract the part of each list
item to compare.
The result list contains all items that appear in LIST1 but not LIST2.
This is non-destructive; it makes a copy of the data if necessary, to
avoid corrupting the original LIST1 and LIST2."
(if (or (null list1) (null list2))
list1
(let ((keyed-list2 (and key (mapcar key list2)))
(result ()))
(while list1
(unless (if key
(member (funcall key (car list1)) keyed-list2)
(member (car list1) list2))
(setq result (cons (car list1) result)))
(setq list1 (cdr list1)))
result)))
GNU Emacs Lisp Reference Manual, Sets and Lists suggests using cl-lib's
cl-set-difference LIST1 LIST2 &key :test :test-not :key
(require 'cl-lib)
(cl-set-difference '(1 2 3) '(2 3 4))
(1)
I'm having issues trying to form code for a problem I want to resolve. It goes like this:
~ Goal: flatten a nested list into one number
If the object is a list, replace the list with the sum of its atoms.
With nested lists, flatten the innermost lists first and work from there.
Example:
(CONDENSE '(2 3 4 (3 1 1 1) (2 3 (1 2)) 5))
(2 3 4 (6) (2 3 (3)) 5)
(2 3 4 (6) (8) 5)
(28)
=> 28
I've tried to implement the flatten list function for this problem and I ended up with this:
(defun condense (lst)
(cond
((null lst) nil)
((atom lst) (list lst)))
(t (append (flatten (apply #'+ (cdr lst))))))
But it gives me errors :(
Could anyone explain to me what is wrong with my processing/code? How can I improve it?
UPDATE: JUNE 5 2012
(defun condense(lxt)
(typecase lxt
(number (abs lxt))
(list
(if (all-atoms lxt)
(calculate lxt)
(condense (mapcar #'condense lxt))))))
So here, in this code, my true intent is shown. I have a function calculate that performs a calculation based off the values in the list. It is not necessarily the same operation each time. Also, I am aware that I am returning the absolute value of the number; I did this because I couldn't find another way to return the number itself. I need to find a way to return the number if the lxt is a number. And I had it recurse two times at the bottom, because this is one way that it loops on itself infinitely until it computes a single number. NOTE: this function doesn't implement a flatten function anymore nor does it use anything from it.
Imagine you have your function already. What does it get? What must it produce?
Given an atom, what does it return? Given a simple list of atoms, what should it return?
(defun condense (x)
(typecase x
(number
; then what?
(condense-number x))
(list
; then what?
(if (all-atoms x)
(condense-list-of-atoms x) ; how to do that?
(process-further-somehow
(condense-lists-inside x))))
; what other clauses, if any, must be here?
))
What must condense-lists-inside do? According to your description, it is to condense the nested lists inside - each into a number, and leave the atoms intact. So it will leave a list of numbers. To process that further somehow, we already "have" a function, condense-list-of-atoms, right?
Now, how to implement condense-lists-inside? That's easy,
(defun condense-lists-inside (xs)
(mapcar #'dowhat xs))
Do what? Why, condense, of course! Remember, we imagine we have it already. As long as it gets what it's meant to get, it shall produce what it is designed to produce. Namely, given an atom or a list (with possibly nested lists inside), it will produce a number.
So now, fill in the blanks, and simplify. In particular, see whether you really need the all-atoms check.
edit: actually, using typecase was an unfortunate choice, as it treats NIL as LIST. We need to treat NIL differently, to return a "zero value" instead. So it's better to use the usual (cond ((null x) ...) ((numberp x) ...) ((listp x) ...) ... ) construct.
About your new code: you've erred: to process the list of atoms returned after (mapcar #'condense x), we have a function calculate that does that, no need to go so far back as to condense itself. When you substitute calculate there, it will become evident that the check for all-atoms is not needed at all; it was only a pedagogical device, to ease the development of the code. :) It is OK to make superfluous choices when we develop, if we then simplify them away, after we've achieved the goal of correctness!
But, removing the all-atoms check will break your requirement #2. The calculation will then proceed as follows
(CONDENSE '(2 3 4 (3 1 1 1) (2 3 (1 2)) 5))
==
(calculate (mapcar #'condense '(2 3 4 (3 1 1 1) (2 3 (1 2)) 5)))
==
(calculate (list 2 3 4 (condense '(3 1 1 1)) (condense '(2 3 (1 2))) 5))
==
(calculate (list 2 3 4 (calculate '(3 1 1 1))
(calculate (list 2 3 (calculate '(1 2)))) 5))
==
(calculate (list 2 3 4 6 (calculate '(2 3 3)) 5))
==
(calculate (list 2 3 4 6 8 5))
==
28
I.e. it'll proceed in left-to-right fashion instead of the from the deepest-nested level out. Imagining the nested list as a tree (which it is), this would "munch" on the tree from its deepest left corner up and to the right; the code with all-atoms check would proceed strictly by the levels up.
So the final simplified code is:
(defun condense (x)
(if (listp x)
(reduce #'+ (mapcar #'condense x))
(abs x)))
a remark: Looking at that last illustration of reduction sequence, a clear picture emerges - of replacing each node in the argument tree with a calculate application. That is a clear case of folding, just such that is done over a tree instead of a plain list, as reduce is.
This can be directly coded with what's known as "car-cdr recursion", replacing each cons cell with an application of a combining function f on two results of recursive calls into car and cdr components of the cell:
(defun condense (x) (reduce-tree x #'+ 0))
(defun reduce-tree (x f z)
(labels ((g (x)
(cond
((consp x) (funcall f (g (car x)) (g (cdr x))))
((numberp x) x)
((null x) z)
(T (error "not a number")))))
(g x)))
As you can see this version is highly recursive, which is not that good.
Is this homework? If so, please mark it as such. Some hints:
are you sure the 'condensation' of the empty list in nil? (maybe you should return a number?)
are you sure the condensation of one element is a list? (maybe you should return a number?)
are you sure the condensation of the last case is a list? (shouldn't you return a number)?
In short, how is your condense ever going to return 28 if all your returned values are lists?
Task: With nested lists, flatten the innermost lists first and work from there
sum
flatten lists
For sum use REDUCE, not APPLY.
For flatten lists you need a loop. Lisp already provides specialized mapping functions.
Slightly more advanced: both the sum and the flatten can be done by a call to REDUCE.
You can also write down the recursion without using a higher-order function like APPLY, REDUCE, ... That's a bit more work.
Here's added the explanation of the errors you were having, actually you were close to solving your problem, just a bit more effort and you would get it right.
; compiling (DEFUN CONDENSE ...)
; file: /tmp/file8dCll3
; in: DEFUN CONDENSE
; (T (APPEND (FLATTEN (APPLY #'+ (CDR LST)))))
;
; caught WARNING:
; The function T is undefined, and its name is reserved
; by ANSI CL so that even
; if it were defined later, the code doing so would not be portable.
;
; compilation unit finished
; Undefined function:
; T
; caught 1 WARNING condition
;STYLE-WARNING: redefining CONDENSE in DEFUN
(defun condense (lst)
(cond
((null lst) nil)
((atom lst) (list lst)))
;.------- this is a function call, not a condition
;| (you closed the parens too early)
(t (append (flatten (apply #'+ (cdr lst))))))
;; Argument Y is not a NUMBER: (3 1 1 1)
;; [Condition of type SIMPLE-TYPE-ERROR]
(defun condense (lst)
(cond
((null lst) nil)
((atom lst) (list lst)); .-- not a number!
;You are calling #'+ -------. |
;on something, which | '(3 4 (3 1 1 1) (2 3 (1 2)) 5)
; is not a number. | |
(t (append (flatten (apply #'+ (cdr lst)))))))
;; You probably wanted to flatten first, and then sum
(defun condense (lst)
(cond
((null lst) nil); .--- returns just the
((atom lst) (list lst)); / atom 28, you can
; .---------------------/ just remove it.
(t (append (apply #'+ (flatten lst))))))
;; Now, you are lucky that append would just return the
;; atom if it's not a list
(defun condense (lst)
(cond
((null lst) nil)
((atom lst) (list lst))
(t (apply #'+ (flatten lst)))))
;; Again, you are lucky because (apply can take enough arguments
;; while your list is reasonably small - this will not always be
;; the case, that is why you need to use something more durable,
;; for example, reduce.
(defun condense (lst)
(cond
((null lst) nil)
((atom lst) (list lst))
(t (reduce #'+ (flatten lst)))))
;; Whoa!
(condense '(2 3 4 (3 1 1 1) (2 3 (1 2)) 5))
This is all given the flatten function actually works.
If your lisp already implements flatten and reduce functions (such as Clojure, which I will use here), you can just do something like:
user=> (defn condense [l] (reduce + 0 (flatten l)))
#'user/condense
user=> (condense [1 [2 [[3 4] 5]]])
15
user=>
Failing that, a naive implementation of those functions might be:
(defn flatten [l]
(cond (nil? l) l
(coll? l) (let [[h & t] l]
(concat (flatten h) (flatten t)))
true [l]))
and:
(defn reduce [op initial-value [h & t]]
(if (nil? t)
(op initial-value h)
(op initial-value (reduce op h t))))
But make sure to check the semantics of the particular Lisp you are using. Also, if you are implementing reduce and flatten, you may want to make them tail recursive which I didn't so as to maintain clarity.
In Common Lisp you would do something like:
(defun flatten (l)
(cond ((null l) l)
((atom l) (list l))
(t (append (flatten (car l))
(flatten (cdr l))))))
and use apply instead of reduce:
(defun condense (l) (apply #'+ (flatten l)))
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