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))))))
Related
From the book "ANSI Common Lisp", p. 100 ch 6.1 :
Suppose that a marble is a structure with a single field called color.
The function UNIFORM-COLOR takes a list of marbles and returns
their color, if they all have the same color, or nil if they have
different colors.
UNIFORM-COLOR is usable on a setf place in order to make the color
of each element of list of marbles be a specific color.
(defstruct marble color)
(defun uniform-color (lst &optional (color (and lst (marble-color (car lst)))))
(every #'(lambda (m) (equal (marble-color m) color)) lst))
(defun (setf uniform-color) (color lst)
(mapc #'(lambda (m) (setf (marble-color m) color)) lst))
How could you implement the defun (setf uniform) in a tail-recursive way instead of using the mapc applicative operator ?
This question is specific to the case of (defun (setf ...)), it is not a question about how recursion or tail-recursion work in general.
i guess you can just call setf recursively:
(defun (setf all-vals) (v ls)
(when ls
(setf (car ls) v)
(setf (all-vals (cdr ls)) v)))
CL-USER> (let ((ls (list 1 2 3 4)))
(setf (all-vals ls) :new-val)
ls)
;;=> (:NEW-VAL :NEW-VAL :NEW-VAL :NEW-VAL)
this is how sbcl expands this:
(defun (setf all-vals) (v ls)
(if ls
(progn
(sb-kernel:%rplaca ls v)
(let* ((#:g328 (cdr ls)) (#:new1 v))
(funcall #'(setf all-vals) #:new1 #:g328)))))
For the specific case of marbles:
(defun (setf uniform-color) (color lst)
(when lst
(setf (marble-color (car lst)) color)
(setf (uniform-color (cdr lst)) color)))
General case
The answer is the same for setf functions and regular functions.
Let's say you have another function f that you want to call to print all the values in a list:
(defun f (list)
(mapc 'print list))
You can rewrite it recursively, you have to consider the two distinct case of recursion for a list, either it is nil or a cons cell:
(defun f (list)
(etypecase list
(null ...)
(cons ...)))
Typically in the null case (this is a type), you won't do anything.
In the general cons case (this is also a type), you have to process the first item and recurse:
(defun f (list)
(etypecase list
(null nil)
(cons
(print (first list))
(f (rest list)))))
The call to f is in tail position: its return value is the return value of the enclosing f, no other processing is done to the return value.
You can do the same with your function.
Note
It looks like the setf function defined in the book does not return the value being set (the color), which is bad practice as far as I know:
all that is guaranteed is that the expansion is an update form that works for that particular implementation, that the left-to-right evaluation of subforms is preserved, and that the ultimate result of evaluating setf is the value or values being stored.
5.1.1 Overview of Places and Generalized Reference
Also, in your specific case you are subject to 5.1.2.9 Other Compound Forms as Places, which also says:
A function named (setf f) must return its first argument as its only value in order to preserve the semantics of setf.
In other words (setf uniform-color) should return color.
But apart from that, the same section guarantees that a call to (setf (uniform-color ...) ...) expands into a call to the function named (setf uniform-color), so it can be a recursive function too. This could have been a problem if this was implemented as macro that expands into the body of your function, but fortunately this is not the case.
Implementation
Setting all the colors in a list named marbles to "yellow" is done as follows:
(setf (uniform-color marbles) "yellow")
You can define (setf uniform-color) recursively by first setting the color of the first marble and then setting the color of the rest of the marbles.
A possible tail-recursive implementation that respects the semantics of setf is:
(defun (setf uniform-color) (color list)
(if list
(destructuring-bind (head . tail) list
(setf (marble-color head) color)
(setf (uniform-color tail) color))
color))
Working on CLISP in Sublime Text.
Exp. in CLISP : less than 1 year
It's already for a while that I'm trying to solve this exercice... without success... as you might guess.
In fact I have to create a function which will modify the list and keeps only sublists which are equals or greater than the given number (watch below)
The list on which I have to work :
(setq liste '((a b) c (d) (e f) (e g x) f))
I'm supposed to find this as result :
(lenght 2 liste) => ((a b) (e f) (e g x))
liste => ((a b) (e f) (e g x))
Here my code :
(defun lenght(number liste)
(cond
((atom liste) nil)
((listp (car liste))
(rplacd liste (lenght number (cdr liste))) )
((<= (lenght number (car liste)) number)
(I don't know what to write) )
((lenght number (cdr liste))) ) )
It will be very kind if you could give me only some clue so as to let me find the good result.
Thanks guys.
Modifying the list does not make much sense, because it gets hairy at the head of the list to retain the original reference. Return a new list.
This is a filtering operation. The usual operator in Common Lisp for that is remove-if-not (or remove-if, or remove, depending on the condition). It takes a predicate that should return whether the element should be kept. In this case, it seems to be (lambda (element) (and (listp element) (>= (length element) minlength))).
(defun filter-by-min-length (minlength list)
(remove-if-not (lambda (element)
(and (listp element)
(>= (length element) minlength)))
list))
In many cases, when the condition is known at compile time, loop produces faster compiled code:
(defun filter-by-min-length (minlength list)
(loop :for element :in list
:when (and (listp element)
(>= (length element) minlength))
:collect element))
This returns a new list that fulfills the condition. You'd call it like (let ((minlength-list (filter-by-min-length 2 raw-list))) …).
Many basic courses insist on recursively using primitive operations on cons cells for teaching purposes at first.
The first attempt usually disregards the possible stack exhaustion. At each step, you first look whether you're at the end (then return nil), whether the first element should be discarded (then return the result of recursing on the rest), or if it should be kept (then cons it to the recursion result).
If tail call optimization is available, you can refactor this to use an accumulator. At each step, instead of first recursing and then consing, you cons a kept value onto the accumulator and pass it to the recursion. At the end, you do not return nil, but reverse the accumulator and return that.
Well, I have found the answer that I was looking for, after scratching my head until blood...
Seriously, here is the solution which is working (and thanks for the correction about length which helped me to find the solution ^^) :
(defun filter-by-min-length (min-length liste)
(cond
((atom liste) nil)
((and (listp (car liste))(>= (length (car liste)) min-length))
(rplacd liste (filter-by-min-length min-length (cdr liste))) )
((filter-by-min-length min-length (cdr liste))) ) )
A non-modifying version
(defun filter-by-min-length (min-length le)
(cond ((atom le) nil)
((and (listp (car le)) (>= (length (car le)) min-length))
(cons (car le) (filter-by-min-length min-length (cdr le))))
(t (filter-by-min-length min-length (cdr le)))))
Test:
(defparameter *liste* '((a b) c (d) (e f) (e g x) f))
(filter-by-min-length 2 *liste*)
;; ((A B) (E F) (E G X))
*liste*
;; ((A B) C (D) (E F) (E G X) F) ; -> *liste* not modified
For building good habits, I would recommend to use defparameter instead of setq, since the behaviour of setq might not always be defined (see here). In the link, it is said:
use defvar, defparameter, or let to introduce new variables. Use setf
and setq to mutate existing variables. Using them to introduce new
variables is undefined behaviour
I am trying to find the position of an atom in the list.
Expected results:
(position-in-list 'a '(a b c d e)) gives 0
(position-in-list 'b '(a b c d e)) gives 1
(position-in-list 'Z '(a b c d e)) gives nil.
I have a function that gives the position correctly when the item is in the list:
(defun position-in-list (letter list)
(cond
((atom list) nil)
((eq (car list) letter) 0)
(t (+ 1 (position-in-list letter (cdr list))))))
The problem is that it doesn't return nil when the item is not present, as if it reaches (atom list) nil it will give this error: *** - 1+: nil is not a number as when it unstacks, it will try to add the values to nil.
Is there a way to adapt this function (keeping the same structure) so that it correctly returns nil when the item is not in the list?
Notes:
I know that there is a position function in the library, but I don't want to use it.
I know my question is similar to this one, but the problem I mention above is not addressed.
* edit *
Thanks to all of you for your answers. Although I don't have the necessary knowledge to understand all the suggestions you mentioned, it was helpful.
I have found another fix to my problem:
(defun position-in-list (letter liste)
(cond
((atom liste) nil)
((equal letter (car liste)) 0)
((position-in-list letter (cdr liste)) (+ 1 (position-in-list letter (cdr liste)))) ) )
One possible solution is to make the recursive function a local function from another function. At the end one would then return from the surrounding function - thus you would not need to return the NIL result from each recursive call.
Local recursive function returns from a function
Local recursive functions can be defined with LABELS.
(defun position-in-list (letter list)
(labels ((position-in-list-aux (letter list)
(cond
((atom list) (return-from position-in-list nil))
((eql (first list) letter) 0)
(t (+ 1 (position-in-list-aux
letter (cdr list)))))))
(position-in-list-aux letter list)))
This RETURN-FROM is possible because the function to return from is visible from the local function.
Recursive function returns to another function
It's also possible to return control to another function using CATCH and THROW:
(defun position-in-list (letter list)
(catch 'position-in-list-catch-tag
(position-in-list-aux letter list)))
(defun position-in-list-aux (letter list)
(cond
((atom list) (throw 'position-in-list-catch-tag nil))
((eql (first list) letter) 0)
(t (+ 1 (position-in-list-aux
letter (cdr list))))))
Test function EQL
Note also that the default test function by convention is EQL, not EQ. This allows also numbers and characters to be used.
You need to check the value returned by the recursive call:
(defun position-in-list (letter list)
(cond
((atom list) nil)
((eq (car list) letter) 0)
(t
(let ((found (position-in-list letter (cdr list))))
(and found
(1+ found))))))
Please note that this implementation is not tail-recursive.
In general, it's useful to provide a :test keyword parameter to pick what equality function we should use, so we do that. It's also handy to give the compiler the ability to tail-call-optimise (note, TCO is not required in Common Lisp, but most compilers will do so with the right optimisation settings, consult your compiler manual), so we use another keyword parameter for that. It also means that whatever we return from the innermost invocation is returned exactly as-is, so it does not matter if we return a number or nil.
(defun position-in-list (element list &key (test #'eql) (position 0))
(cond ((null list) nil)
((funcall test element (car list)) position)
(t (position-in-list element
(cdr list)
:test test :position (1+ position)))))
Of course, it is probably better to wrap the TCO-friendly recursion in an inner function, so we (as Rainer Joswig correctly points out) don't expose internal implementation details.
(defun position-in-list (element list &key (test #'eql)
(labels ((internal (list position)
(cond ((null list) nil)
((eql element (car list)) position)
(t (internal (cdr list) (1+ position))))))
(internals list 0)))
I'm trying to create a function in scheme that's called allAssociation. It takes in 2 parameters, a list of symbols and an assoc-list. Calling this function should return a list of data with elements that correspond to the keys of the assoc-list.
Here is an example:
Input:
(allAssociation '(a c d) '((a allen)(b bob)(c (carl cooper))(d doug)))
Output:
(allen (carl cooper) doug).
I am trying to use map and lambda to implement this function, but I am a little stumped.
Currently I have this snippet of code:
(define AllAssociation
(lambda (key alist)
(if (null? alist)
'()
[insert rest of logic]
)))
But I am struggling with implementing the logic of using map to match up each of the elements of the key with the association list. Any help would be much appreciated, for I am very new to scheme. Thank you.
Basically you iterate over the keys list, and use assoc to retrieve the first matching element in list lst.
If you need to use map (as your text suggests), then something like this will do:
(define all-association
(lambda (keys lst)
(map (lambda (key) (cadr (assoc key lst)))
keys)))
If you have to do it without map (as your code suggests), the equivalent would be:
(define all-association
(lambda (keys lst)
(if (null? keys)
'()
(cons (cadr (assoc (car keys) lst))
(all-association (cdr keys) lst)))))
Testing:
> (all-association '(a c d) '((a allen)(b bob)(c (carl cooper))(d doug)))
'(allen (carl cooper) doug)
To set some context, I'm in the process of learning Clojure, and Lisp development more generally. On my path to Lisp, I'm currently working through the "Little" series in an effort to solidify a foundation in functional programming and recursive-based solution solving. In "The Little Schemer," I've worked through many of the exercises, however, I'm struggling a bit to convert some of them to Clojure. More specifically, I'm struggling to convert them to use "recur" so as to enable TCO. For example, here is a Clojure-based implementation to the "occurs*" function (from Little Schemer) which counts the number of occurrences of an atom appearing within a list of S-expressions:
(defn atom? [l]
(not (list? l)))
(defn occurs [a lst]
(cond
(empty? lst) 0
(atom? (first lst))
(cond
(= a (first lst)) (inc (occurs a (rest lst)))
true (occurs a (rest lst)))
true (+ (occurs a (first lst))
(occurs a (rest lst)))))
Basically, (occurs 'abc '(abc (def abc) (abc (abc def) (def (((((abc))))))))) will evaluate to 5. The obvious problem is that this definition consumes stack frames and will blow the stack if given a list of S-expressions too deep.
Now, I understand the option of refactoring recursive functions to use an accumulator parameter to enable putting the recursive call into the tail position (to allow for TCO), but I'm struggling if this option is even applicable to situations such as this one.
Here's how far I get if I try to refactor this using "recur" along with using an accumulator parameter:
(defn recur-occurs [a lst]
(letfn [(myoccurs [a lst count]
(cond
(empty? lst) 0
(atom? (first lst))
(cond
(= a (first lst)) (recur a (rest lst) (inc count))
true (recur a (rest lst) count))
true (+ (recur a (first lst) count)
(recur a (rest lst) count))))]
(myoccurs a lst 0)))
So, I feel like I'm almost there, but not quite. The obvious problem is my "else" clause in which the head of the list is not an atom. Conceptually, I want to sum the result of recurring over the first element in the list with the result of recurring over the rest of the list. I'm struggling in my head on how to refactor this such that the recurs can be moved to the tail position.
Are there additional techniques to the "accumulator" pattern to achieving getting your recursive calls put into the tail position that I should be applying here, or, is the issue simply more "fundamental" and that there isn't a clean Clojure-based solution due to the JVM's lack of TCO? If the latter, generally speaking, what should be the general pattern for Clojure programs to use that need to recur over a list of S-expressions? For what it's worth, I've seen the multi method w/lazy-seq technique used (page 151 of Halloway's "Programming Clojure" for reference) to "Replace Recursion with Laziness" - but I'm not sure how to apply that pattern to this example in which I'm not attempting to build a list, but to compute a single integer value.
Thank you in advance for any guidance on this.
Firstly, I must advise you to not worry much about implementation snags like stack overflows as you make your way through The Little Schemer. It is good to be conscientious of issues like the lack of tail call optimization when you're programming in anger, but the main point of the book is to teach you to think recursively. Converting the examples accumulator-passing style is certainly good practice, but it's essentially ditching recursion in favor of iteration.
However, and I must preface this with a spoiler warning, there is a way to keep the same recursive algorithm without being subject to the whims of the JVM stack. We can use continuation-passing style to make our own stack in the form of an extra anonymous function argument k:
(defn occurs-cps [a lst k]
(cond
(empty? lst) (k 0)
(atom? (first lst))
(cond
(= a (first lst)) (occurs-cps a (rest lst)
(fn [v] (k (inc v))))
:else (occurs-cps a (rest lst) k))
:else (occurs-cps a (first lst)
(fn [fst]
(occurs-cps a (rest lst)
(fn [rst] (k (+ fst rst))))))))
Instead of the stack being created implicitly by our non-tail function calls, we bundle up "what's left to do" after each call to occurs, and pass it along as the next continuation k. When we invoke it, we start off with a k that represents nothing left to do, the identity function:
scratch.core=> (occurs-cps 'abc
'(abc (def abc) (abc (abc def) (def (((((abc))))))))
(fn [v] v))
5
I won't go further into the details of how to do CPS, as that's for a later chapter of TLS. However, I will note that this of course doesn't yet work completely:
scratch.core=> (def ls (repeat 20000 'foo))
#'scratch.core/ls
scratch.core=> (occurs-cps 'foo ls (fn [v] v))
java.lang.StackOverflowError (NO_SOURCE_FILE:0)
CPS lets us move all of our non-trivial, stack-building calls to tail position, but in Clojure we need to take the extra step of replacing them with recur:
(defn occurs-cps-recur [a lst k]
(cond
(empty? lst) (k 0)
(atom? (first lst))
(cond
(= a (first lst)) (recur a (rest lst)
(fn [v] (k (inc v))))
:else (recur a (rest lst) k))
:else (recur a (first lst)
(fn [fst]
(recur a (rest lst) ;; Problem
(fn [rst] (k (+ fst rst))))))))
Alas, this goes wrong: java.lang.IllegalArgumentException: Mismatched argument count to recur, expected: 1 args, got: 3 (core.clj:39). The very last recur actually refers to the fn right above it, the one we're using to represent our continuations! We can get good behavior most of the time by changing just that recur to a call to occurs-cps-recur, but pathologically-nested input will still overflow the stack:
scratch.core=> (occurs-cps-recur 'foo ls (fn [v] v))
20000
scratch.core=> (def nested (reduce (fn [onion _] (list onion))
'foo (range 20000)))
#'scratch.core/nested
scratch.core=> (occurs-cps-recur 'foo nested (fn [v] v))
Java.lang.StackOverflowError (NO_SOURCE_FILE:0)
Instead of making the call to occurs-* and expecting it to give back an answer, we can have it return a thunk immediately. When we invoke that thunk, it'll go off and do some work right up until it does a recursive call, which in turn will return another thunk. This is trampolined style, and the function that "bounces" our thunks is trampoline. Returning a thunk each time we make a recursive call bounds our stack size to one call at a time, so our only limit is the heap:
(defn occurs-cps-tramp [a lst k]
(fn []
(cond
(empty? lst) (k 0)
(atom? (first lst))
(cond
(= a (first lst)) (occurs-cps-tramp a (rest lst)
(fn [v] (k (inc v))))
:else (occurs-cps-tramp a (rest lst) k))
:else (occurs-cps-tramp a (first lst)
(fn [fst]
(occurs-cps-tramp a (rest lst)
(fn [rst] (k (+ fst rst)))))))))
(declare done answer)
(defn my-trampoline [th]
(if done
answer
(recur (th))))
(defn empty-k [v]
(set! answer v)
(set! done true))
(defn run []
(binding [done false answer 'whocares]
(my-trampoline (occurs-cps-tramp 'foo nested empty-k))))
;; scratch.core=> (run)
;; 1
Note that Clojure has a built-in trampoline (with some limitations on the return type). Using that instead, we don't need a specialized empty-k:
scratch.core=> (trampoline (occurs-cps-tramp 'foo nested (fn [v] v)))
1
Trampolining is certainly a cool technique, but the prerequisite to trampoline a program is that it must contain only tail calls; CPS is the real star here. It lets you define your algorithm with the clarity of natural recursion, and through correctness-preserving transformations, express it efficiently on any host that has a single loop and a heap.
You can't do this with a fixed amount of memory. You can consume stack, or heap; that's the decision you get to make. If I were writing this in Clojure I would do it with map and reduce rather than with manual recursion:
(defn occurs [x coll]
(if (coll? coll)
(reduce + (map #(occurs x %) coll))
(if (= x coll)
1, 0)))
Note that shorter solutions exist if you use tree-seq or flatten, but at that point most of the problem is gone so there's not much to learn.
Edit
Here's a version that doesn't use any stack, instead letting its queue get larger and larger (using up heap).
(defn heap-occurs [item coll]
(loop [count 0, queue coll]
(if-let [[x & xs] (seq queue)]
(if (coll? x)
(recur count (concat x xs))
(recur (+ (if (= item x) 1, 0)
count)
xs))
count)))