I'm new to scheme and trying to learn functions. I want to create a function where I can count all occurrences of the atom "a" in an argument. This is what I have written so far. I'm not sure what to write in the third condition. Please help out.
(define (count-a arg)
(COND
((null? arg) 0)
((eq? arg 'a) 1)
((list? arg) ( ___ + ( ___ count-a arg)))
(else 0)
))
This is the output i want:
(count-a 'a)
1
(count-a 'aa)
0
(count-a '(a))
1
(count-a '(ab c)
0
(count-a '(a (b c) (c (d a) a) (((a b)))))
5
(___ + ( ___ count-a arg)) doesn't seem right to me. Remember Scheme is a prefix language. It's (+ 1 2 3) instead of 1 + 2 + 3.
In the third one you have two lists parts. eg. '(a a) so you need to call count-a on the car and on the cdr of the list and add the results together. eg. (count-a '(a a)) should give the same result as (+ (count-a 'a) (count-a '(a))
Good luck
Welcome to Stack Overflow!
Solution:
(define (count-a arg)
(cond ((null? arg) 0)
((not (pair? arg))
(if (equal? arg 'a)
1
0))
;; At this point we know arg is a pair, and we recurse.
(else (+ (count-a (car arg)) (count-a (cdr arg))))))
Test:
Here are the tests you specified, compressed into a single line.
;; Chibi-Scheme REPL - other implementations might look different.
> (map count-a '(a aa (a) (ab c) (a (b c) (c (d a) a) (((a b))))))
(1 0 1 0 4)
You didn't say what you want to happen if arg is a dotted pair. But let's check it out just for fun.
> (map count-a '((ab . '()) (ab . a) (a . a)))
(0 1 2)
So when I run your last test on my code, it yields 4 where you expected 5. I maintain that my code is correct and your test specification is incorrect, as there are only four instances of 'a in the argument of count-a.
Discussion:
You specified in your headline that the thing the count-a function will be counting is an atom. So you have to check whether arg is an atom or not. Since Scheme doesn't have an atom? function, I'll assume that an atom is anything that's not '() and not a pair. (This is consistent with the atom function of Common Lisp, as well as other Lisp dialects.)
Since your code already deals with arg being '(), we only have to deal with arg being, or not being a pair.
If arg is not a pair and (equal? arg 'a), then (count-a arg) equals 1. Else, it equals 0.
If arg is a pair, we can recurse into car arg) and (cdr arg), however deeply nested arg may be, and increase our count whenever we find an atom that equals a.
Hope that helps.
Related
So, id like to take in a list of numbers, atomize it (to remove nested integers), then find the max value. I have two functions written that accomplish this individually, but can't figure out how to combine them in LISP so I can make one call and have them both run. Any help would be appreciated.
:Atomize function to remove nests
:(atomify ‘( a (b c) (e (f (g h) i)) j)->(a b c e f g h i j)
(defun atomify (numbers)
(cond ((null numbers) nil)
((atom (car numbers))
(cons (car numbers)
(atomify (cdr numbers))))
(t
(append (atomify (car numbers))
(atomify (cdr numbers))))))
:Max value of a list of integers function
(defun large_atom (numbers)
(if (null numbers)
0
(max (first numbers)
(large_atom (rest numbers)))))
Jamie. Your way has two steps:
1. Flatten list
2. Find max value from result of 1'st step
In this case it's true way. But you need do it with one function call. It's easy. Just use labels, apply and of course max
(defun foo (lst)
(labels ((flatten (lst acc)
(cond
((null lst)
acc)
((consp (car lst))
(flatten (cdr lst) (flatten (car lst) acc)))
(t
(flatten (cdr lst) (cons (car lst) acc))))))
(apply #'max (flatten lst nil))))
Another way, is do not flatten source list. But in this case you need find first value to compare with other values. Try it yourself.
Here is another way to solve the problem: rather than flattening the list, this walks down it recursively. This is very explicit about what the structure of the list must be: a good list is a non-null proper list each of whose elements is either an integer or a good list.
The problem with this approach is that it's not tail recursive so it will necessarily fail on very large structures (and even if it was tail recursive CL does not promise to deal with tail recursion.
(defun greatest-integer (good-list)
;; a good list is one of:
;; - a cons of a good list and either a good list or ()
;; - a cons of an integer and either a good list or ()
;; In particular it can't be () and it can't be an improper list
;;
(destructuring-bind (a . b) good-list
;; a can be an integer or a good list, b can be null or a good list
(etypecase b
(null
(etypecase a
(integer a)
(cons (greatest-integer a))))
(cons
(max (etypecase a
(integer a)
(cons (greatest-integer a)))
(greatest-integer b))))))
I have writte a list reverse function in lisp and I wanted to test it but I had an error and I couldn't solve it
the function and calling is below :
(defun myreverse (list)
(cond((null list) nil))
(cons (myreverse(cdr list) (car list))))
(myreverse '(1 2 3))
any help will be appreciated...
The arguments when you defun myreverse are (list), thus when you call it (myreverse '(1 2 3)) list gets bound to (1 2 3).
Since the list is not null you suddenly do (myreverse '(2 3) 1) and list gets bound to (2 3), but what do 1 get bound to? You have no more than one argument thus the call is invalid and warrants an error.
Hint1: There is a way to make optional arguments:
(defun test (a &optional (b 0) (c 0))
(+ a b c))
(test 10) ; ==> 10
(test 10 1 2) ; ==> 13
Hint2: You need to build a list not just pass a bare element. The passed list will be the tail of the next round until the every element is added.
The bad answer (or one of the bad answers):
(defun reverse (list)
(cond ((null list) list)
(t (append (reverse (cdr list)) (cons (car list) nil)))))
A better answer:
(defun reverse (list)
(reverse-aux list nil))
(defun reverse-aux (list result)
(cond ((null list) result)
(t (reverse-aux (cdr list) (cons (car list) result)))))
It's the basic example we use in comparison to the definition of 'append' in lessons to differentiate tail recursion.
I've got a bit exotic situation. I need to compare functions, but rather by their "origin" than by "instances". Here what I actually mean:
(define-values (a b c d) (values #f #f #f #f))
(define (f x)
(let ([g (λ (y) (printf "Please tell ~a this is ~a\n" x y))]
[h (curry printf "Don't tell ~a this is ~a\n" x)])
(if a
(set! b g)
(set! a g))
(if c
(set! d h)
(set! c h))))
(f "me")
(f " me")
(a "possible")
(d "impossible")
(equal? a b) ; <==== Is it possible to compare these guys
(equal? c d) ; <==== to get #t in both cases?
In both cases we get two different "instances" of functions (even with different values captured), but both declared in the same location of the source code. Of course, getting the actual text of the body of those functions will solve the problem, but other answers here on SO tell that this is impossible in Racket. Are there some tricks that can help me?
Edit:
This is not the question on theoretical equivalence of functions. This is completely technical question, much rather on Racket's functions representation in a compiled code. So it can be reformulated, for example, in a following way: can I get the line number of some routine from 'user' code? I suppose this should be feasible because Racket debugger somehow obtains it.
It can be done even without support from racket internals if you control the code that makes the functions. If you keep a counter (or some identifier) that will denote the particular lambda it can wrap different closures in a struct that can have the same identity from macro expansion. Here is a demonstration:
#lang racket
;; makes a procedure object that can have other data connected to it
(struct proc (id obj)
#:property prop:procedure
(struct-field-index obj)
#:methods gen:custom-write
[(define (write-proc x port mode)
(display (format "#<procedure-id-~a>" (proc-id x)) port))])
;; compares the ids of two proc objects if they are proc objects
(define (proc-equal? a b)
(and (proc? a)
(proc? b)
(= (proc-id a) (proc-id b))))
;; extends equal?, candidate to provide
(define (equal*? a b)
(or (proc-equal? a b)
(equal? a b)))
;; the state we keep
(begin-for-syntax
(define unique-proc-id-per-code 0))
;; a macro that changes (lambda* ...) to
;; (proc expansion-id (lambda ...))
(define-syntax (lambda* stx)
(let ((proc-id unique-proc-id-per-code))
(set! unique-proc-id-per-code (add1 unique-proc-id-per-code))
#`(proc #,(datum->syntax stx proc-id) (lambda #,#(datum->syntax stx (cdr (syntax-e stx)))))))
;; test with making a counter
(define counter-from
(lambda* (from)
(lambda* ()
(begin0
from
(set! from (add1 from))))))
;; evaluatin the outer shows it has id 0
counter-from ; ==> #<procedure-id-0>
;; make two counters that both use the inner lambda
(define from10 (counter-from 10))
(define from20 (counter-from 20))
;; both have the same expansion id
from10 ; ==> #<procedure-id-1>
from20 ; ==> #<procedure-id-1>
;; they are not equal?
(equal? from10 from20) ; ==> #f (different object instances of proc)
;; but they are procedure-equal?
(proc-equal? from10 from20) ; ==> #t (same id, thus came from same macroexpansion)
Disclaimer: I'm more a schemer than a racketeer so this could perhaps have been done more elegantly and I have no idea what performance penalties this will give.
Quite often I need to replace subsequence of certain elements with another sequence of the same type, but, probably with different length. Implementation of such function is no challenge, this is what I use now:
(defun substitute* (new old where &key key (test #'eql))
(funcall (alambda (rest)
(aif (search old rest :key key :test test)
(concatenate (etypecase rest
(string 'string)
(vector 'vector)
(list 'list))
(subseq rest 0 it)
new
(self (subseq rest (+ it (length old)))))
rest))
where))
Works like this:
CL-USER> (substitute* '(x y) '(z) '(1 z 5 8 y z))
(1 X Y 5 8 Y X Y)
CL-USER> (substitute* "green button" "red button"
"here are red indicator, red button and red wire")
"here are red indicator, green button and red wire"
CL-USER> (substitute* #(4) #(2 2) #(2 2 2 2 2))
#(4 4 2)
You see, it's very handy and useful, so I've feeling that I'm reinventing wheel and it must be in the standard library, I just don't know its name (sometimes names are not obvious, you may search for filter while what you need is set-difference).
As a result of compromise between clarity and efficiency:
(defun substitute* (new old where &key key (test #'eql))
(let ((type (etypecase where
(string 'string)
(vector 'vector)
(list 'list)))
(new (coerce new 'list))
(old (coerce old 'list))
(where (coerce where 'list)))
(coerce (funcall (alambda (rest)
(aif (search old rest :key key :test test)
(append (remove-if (constantly t) rest :start it)
new
(self (nthcdr (+ it (length old)) rest)))
rest))
where)
type)))
I don't think that there's any standard function for this. It's more complicated than the standard replace family of functions. Those can operate destructively because you know in advance that you can replace element by element. Even in that case, it's still somewhat difficult to do this efficiently, because the access time for lists and vectors is very different, so general-purpose functions like subseq can be problematic. As Rainer Joswig pointed out in a comment:
It's kind of unfortunate that for many algorithms over sequences there
is no single efficient implementation. I see often that there are two
versions, one for lists and one for vectors, which then get hidden
behind a dispatching function. For a hack a simple common version is
fine, but for a library function, often there are different
implementations - like shown here.
(In fact, in doing a bit of research on whether some library contains a function for this, one of the first Google results I got was a question on Code Review, Generic sequence splitter in Common Lisp, in which Rainer and I both had some comment similar to those here.)
A version for lists
However, your implementation is rather inefficient because it makes multiple copies of the the remainders of sequences. E.g., when you replace (z) in (1 z 2 z 3 z), with (x y), you'll first make (3 x y), then copy it in making (2 x y 3 z y), and then you'll copy that in making (1 x y 2 x y 3 x y). You might be better off in doing one pass over the sequence, determining the indices of the subsequences to replace, or collecting the bits that need to don't need to be replaced, etc. You'll probably want separate implementations for lists and for other sequences. E.g., with a list, you might do:
(defun splice-replace-list (old new list)
(do ((new (coerce new 'list))
(old-len (length old))
(parts '()))
((endp list)
(reduce 'append (nreverse parts) :from-end t))
(let ((pos (search old list)))
(push (subseq list 0 pos) parts)
(cond
((null pos)
(setf list nil))
(t
(push new parts)
(setf list (nthcdr (+ old-len pos) list)))))))
There are some optimizations you could make here, if you wanted. For instance, you could implement a search-list that, rather than returning the position of the first instance of the sought sequence, could return a copy of the head up until that point and the tail beginning with the sequence as multiple values, or even the copied head, and the tail after the sequence, since that's what you're really interested in, in this case. Additionally, you could do something a bit more efficient than (reduce 'append (nreverse parts) :from-end t) by not reversing parts, but using a reversed append. E.g.,
(flet ((xappend (l2 l1)
(append l1 l2)))
(reduce #'xappend '((5 6) (x y) (3 4) (x y))))
;=> (x y 3 4 x y 5 6)
I wrote this in a somewhat imperative style, but there's no reason that you can't use a functional style if you want. Be warned that not all Lisp implementation support tail call optimization, so it might be better to use do, but you certainly don't have to. Here's a more functional version:
(defun splice-replace-list (old new list)
(let ((new-list (coerce new 'list))
(old-len (length old)))
(labels ((keep-going (list parts)
(if (endp list)
(reduce 'append (nreverse parts) :from-end t)
(let* ((pos (search old list))
(parts (list* (subseq list 0 pos) parts)))
(if (null pos)
(keep-going '() parts)
(keep-going (nthcdr (+ old-len pos) list)
(list* new-list parts)))))))
(keep-going list '()))))
A version for vectors
For non lists, this is more difficult, because you don't have the specific sequence type that you're supposed to be using for the result. This is why functions like concatenate require a result-type argument. You can use array-element-type to get an element type for the input sequence, and then use make-array to get a sequence big enough to hold the result. That's trickier code, and will be more complicated. E.g., here's a first attempt. It's more complicated, but you'll get a result that's pretty close to the original vector type:
(defun splice-replace-vector (old new vector &aux (new-len (length new)))
(flet ((assemble-result (length parts)
(let ((result (make-array length :element-type (array-element-type vector)))
(start 0))
(dolist (part parts result)
(cond
((consp part)
(destructuring-bind (begin . end) part
(replace result vector :start1 start :start2 begin :end2 end)
(incf start (- end begin))))
(t
(replace result new :start1 start)
(incf start new-len)))))))
(do ((old-len (length old))
(total-len 0)
(start 0)
(indices '()))
((null start) (assemble-result total-len (nreverse indices)))
(let ((pos (search old vector :start2 start)))
(cond
((null pos)
(let ((vlength (length vector)))
(push (cons start vlength) indices)
(incf total-len (- vlength start))
(setf start nil)))
(t
(push (cons start pos) indices)
(push t indices)
(incf total-len (- pos start))
(incf total-len new-len)
(setf start (+ pos old-len))))))))
CL-USER> (splice-replace-vector '(#\z) '(#\x #\y) "12z")
"12xy"
CL-USER> (splice-replace-vector '(z) '(x y) #(x y))
#(X Y)
CL-USER> (splice-replace-vector '(z) '(x y) #(1 z 2 z 3 4 z))
#(1 X Y 2 X Y 3 4 X Y)
CL-USER> (splice-replace-vector '(#\z) #(#\x #\y) "1z2z34z")
"1xy2xy34xy"
If you only want to make one pass through the input vector, then you could use an adjustable array as the output, and append to it. An adjustable array will have a bit more overhead than a fixed size array, but it does make the code a bit simpler.
(defun splice-replace-vector (old new vector)
(do ((vlength (length vector))
(vnew (coerce new 'vector))
(nlength (length new))
(result (make-array 0
:element-type (array-element-type vector)
:adjustable t
:fill-pointer 0))
(start 0))
((eql start vlength) result)
(let ((pos (search old vector :start2 start)))
(cond
;; add the remaining elements in vector to result
((null pos)
(do () ((eql start vlength))
(vector-push-extend (aref vector start) result)
(incf start)))
;; add the elements between start and pos to the result,
;; add a copy of new to result, and increment start
;; accordingly
(t
;; the copying here could be improved with adjust-array,
;; and replace, instead of repeated calls to vector-push-extend
(do () ((eql start pos))
(vector-push-extend (aref vector start) result)
(incf start))
(loop for x across vnew
do (vector-push-extend x result))
(incf start (1- nlength)))))))
A “generic” version
Using these two functions, you could define a general splice-replace that checks the type of the original input sequence and calls the appropriate function:
(defun splice-replace (old new sequence)
(etypecase sequence
(list (splice-replace-list old new sequence))
(vector (splice-replace-vector old new sequence))))
CL-USER> (splice-replace #(z) '(x y) #(1 z 2 z 3 4 z))
#(1 X Y 2 X Y 3 4 X Y)
CL-USER> (splice-replace '(z) #(x y) '(1 z 2 z 3 4 z))
(1 X Y 2 X Y 3 4 X Y)
Here is what the function should do:
I am giving it list of "pairs" that look like (((a . b) . c) ((a . b) . c) ((a. b) . c) ...)
where:
a means if the vertex is visited 1 for yes 0 for no
b means what is the value of the shortest path to the vertex so far (if it is -1 it is infinity)
c is the number of the parent (if it has so far if it doesn't it is the number of the pair if you count the first pair for 1 second for 2 and etc.)
The function should return the number of the next unvisited pair (vertex) with the lowest cost of the path so far.
Example:
(((0 . 10) . 1) ((0 . 4) . 2) ((1 . 3) . 5) ...) here it should return the number 2.
Here is the code
(define (chooseNextLowest pairs num retV pointer)
(if (null? pairs)
retV
(if (checkIfPairVis (caar pairs))
(chooseNextLowest (cdr pairs) num retV (+ 1 pointer))
(if (= -1 num)
(chooseNextLowest (cdr pairs) (cdaar pairs) pointer (+ 1 pointer))
(if (not (= -1 (cdaar pairs)))
(if (< (cdaar pairs) num)
(chooseNextLowest (cdr pairs) (cdaar pairs) pointer (+ 1 pointer))
(chooseNextLowest (cdr pairs) num retV (+ 1 pointer))))))))
I have used some function that are predefined but I think it's clear by their names what they do.
I call it with num = -1 , retV = -1 and pointer = 1, since I use -1 for infinity and I am sure retV will be changed at least 1 time because everytime I call this function will be at least 1 unvisited pair.
They work fine also this function seems to work fine when I use it with some testPairs but when I use pairs that are returned from other function (since I have to choose everytime the lowest cost unvisited vertex after I update the information in the pairs) it doesnt return any value.
Maybe you will ask to see the other function too but I can't give it at the moment since if I give it I have to give the whole sorce code to make sense so I hope the mistake is somewhere here but I can't find it.
The other function return normal pairs in the type I want them ((a . b ) . c) and etc.
Thank you very much. I am sure I didn't make some things clear so If you have questions feel free to ask me.
After formatting the code it's obvious that in the second deepest if you are lacking a alternative. if without alternative is very new in Scheme but:
(if #f 'true) ;; ==> #undefined
Looking at your code, specially checkIfPairVis it seems you do caar and that's ok for the object, but not for the list with an object. The best way to eliminate such things would be to make accessors in your code which also will make your code easier to read:
(define (choose-next-lowest pairs num ret-v pointer)
;; accessor based on object
(define vertex-visited caar)
(define vertex-shortest cdar)
(define vertex-parents cdr)
(if (null? pairs)
ret-v
(let ((obj (car pairs)))
(cond
((check-if-pair-vis (vertex-visited obj))
(choose-next-lowest (cdr pairs) num ret-v (+ 1 pointer)))
...))))
After fixing that accessor I get 2 as you predicted.
It could be other things wrong of course. Seems to me you need to debug. In DrRacket IDE you could step through your code to ensure it works as designed.
PS: A named let will add accumulators and variables you don't need to expose:
(define (choose-next-lowest pairs)
(define vertex-visited caar)
(define vertex-shortest cdar)
(define vertex-parents cdr)
(define (vertex-visited? v)
(= 1 (vertex-visited v)))
(let rec ((pairs pairs) (num -1) (ret-v -1) (pointer 1))
(if (null? pairs)
ret-v
(let ((obj (car pairs)))
(cond
((vertex-visited? obj) (rec (cdr pairs) num ret-v (+ 1 pointer)))
((= -1 num) (rec (cdr pairs) (vertex-shortest obj) pointer (+ 1 pointer)))
((= -1 (vertex-shortest obj)) 'undefined) ;; something wrong here?
((< (vertex-shortest obj) num) (rec (cdr pairs) (vertex-shortest obj) pointer (+ 1 pointer)))
(else (rec (cdr pairs) num ret-v (+ 1 pointer))))))))
(choose-next-lowest '(((0 . 10) . 1) ((0 . 4) . 2) ((1 . 3) . 5))) ; ==> 2
Your conditional at (if (not (= -1 (cdaar pairs))) ... only has a consequent clause. Without an alternate clause the return of if is undefined (officially). Specifically:
(if (not (= -1 (cdaar pairs)))
(if (< (cdaar pairs) num)
(chooseNextLowest (cdr pairs) (cdaar pairs) pointer (+ 1 pointer))
(chooseNextLowest (cdr pairs) num retV (+ 1 pointer)))
<something here>)))))
Illustrating how if has an undefined return:
> (if #f 'yes 'no)
no
> (if #f 'yes)
> ; <= nothing printed as a return, just a prompt displayed.