Scheme / Racket Vector in Vector transformation - vector

I'm having a problem transforming a vector like this:
#(#(1 2 3)#(1 2 3)#(1 2 3)#(1 2 3)#(1 2 3)))
Into one like this:
#(#(1 1 1 1 1) #(2 2 2 2 2) #(3 3 3 3 3))
I wrote a piece of test code but the output is wrong. I went into the debugger and I think I know which line of code cause the problem. I can't seems to find a way to make it work. Any help is greatly appreciated.
(define (test)
(let* ((table #(#(1 2 3)#(1 2 3)#(1 2 3)#(1 2 3)#(1 2 3)))
(counter 5)
(size 3)
(new-table (make-vector size (make-vector counter #f))))
(let loop ((sc 0)
(cc 0))
(when (not (= cc counter))
(if (not (= sc size))
(begin (vector-set! (vector-ref new-table sc) cc (vector-ref (vector-ref table cc) sc))
(loop (+ 1 sc) cc))
(loop 0 (+ 1 cc)))))
(display new-table)))
> (test)
#(#(3 3 3 3 3) #(3 3 3 3 3) #(3 3 3 3 3))

You can also use vector-map to get the desired output:
(define table #(#(1 2 3) #(1 2 3) #(1 2 3) #(1 2 3) #(1 2 3)))
(apply vector-map vector (vector->list table))

There's a problem in this part:
(make-vector size (make-vector counter #f))
Why? because you're copying the exact same vector in all off new-table's positions, so whenever you update one value, it'll change all of them at the same time. It's easy to see this:
(define new-table (make-vector 3 (make-vector 3 #f)))
(vector-set! (vector-ref new-table 0) 0 42) ; we modify a single position ...
new-table
=> '#(#(42 #f #f) #(42 #f #f) #(42 #f #f)) ; ... but all of them changed!
You have to initialize the vector at the beginning; a fixed version of your code would look like this:
(let* ((table '#(#(1 2 3) #(1 2 3) #(1 2 3) #(1 2 3) #(1 2 3)))
(counter (vector-length table))
(size (vector-length (vector-ref table 0)))
(new-table (make-vector size)))
; initialization
(let loop ((i 0))
(when (< i size)
(vector-set! new-table i (make-vector counter))
(loop (+ i 1))))
(let loop ((sc 0)
(cc 0))
(when (not (= cc counter))
(if (not (= sc size))
(begin
(vector-set! (vector-ref new-table sc) cc
(vector-ref (vector-ref table cc) sc))
(loop (+ 1 sc) cc))
(loop 0 (+ 1 cc))))
new-table))
However, the above solution is hard to understand. Fortunately, this seems like a good problem to use Racket's Iterations and Comprehensions, so you don't have to worry about explicitly using recursion for iteration, leading to a much clearer solution:
(let* ((table '#(#(1 2 3) #(1 2 3) #(1 2 3) #(1 2 3) #(1 2 3)))
(counter (vector-length table))
(size (vector-length (vector-ref table 0)))
(new-table (make-vector size)))
(for ([sc (in-range size)])
(vector-set! new-table sc (make-vector counter)) ; initialization
(for ([cc (in-range counter)])
(vector-set! (vector-ref new-table sc) cc
(vector-ref (vector-ref table cc) sc))))
new-table)
Either way, the output is as expected:
=> '#(#(1 1 1 1 1) #(2 2 2 2 2) #(3 3 3 3 3))
Note: As it is, this is a procedural programming-style solution, which modifies the new vectors in-place and has the advantage of being fast and efficient (it doesn't create more vectors or lists beyond the strictly necessary), but truth be told, this is not the usual way to solve problems in Scheme. For a functional programming-style solution, more in the spirit of Scheme, see #Ankur's answer.

Related

Implementation of Heaps Algorithm in Scheme (permutation generation)

I want to implement Heap's algorithm in Scheme (Gambit).
I read his paper and checked out lots of resources but I haven't found many functional language implementations.
I would like to at least get the number of possible permutations.
The next step would be to actually print out all possible permutations.
Here is what I have so far:
3 (define (heap lst n)
4 (if (= n 1)
5 0
6 (let ((i 1) (temp 0))
7 (if (< i n)
8 (begin
9 (heap lst (- n 1))
10 (cond
11 ; if even: 1 to n -1 consecutively cell selected
12 ((= 0 (modulo n 2))
13 ;(cons (car lst) (heap (cdr lst) (length (cdr lst)))))
14 (+ 1 (heap (cdr lst) (length (cdr lst)))))
15
16 ; if odd: first cell selectd
17 ((= 1 (modulo n 2))
18 ;(cons (car lst) (heap (cdr lst) (length (cdr lst)))))
19 (+ 1 (heap (car lst) 1)))
20 )
21 )
22 0
23 )
24 )
25 )
26 )
27
28 (define myLst '(a b c))
29
30 (display (heap myLst (length myLst)))
31 (newline)
I'm sure this is way off but it's as close as I could get.
Any help would be great, thanks.
Here's a 1-to-1 transcription of the algorithm described on the Wikipedia page. Since the algorithm makes heavy use of indexing I've used a vector as a data structure rather than a list:
(define (generate n A)
(cond
((= n 1) (display A)
(newline))
(else (let loop ((i 0))
(generate (- n 1) A)
(if (even? n)
(swap A i (- n 1))
(swap A 0 (- n 1)))
(if (< i (- n 2))
(loop (+ i 1))
(generate (- n 1) A))))))
and the swap helper procedure:
(define (swap A i1 i2)
(let ((tmp (vector-ref A i1)))
(vector-set! A i1 (vector-ref A i2))
(vector-set! A i2 tmp)))
Testing:
Gambit v4.8.4
> (generate 3 (vector 'a 'b 'c))
#(a b c)
#(b a c)
#(c a b)
#(a c b)
#(b c a)
#(c b a)

Position in list scheme

I'm not sure how to do this and couldn't find an example of it anywhere. How do I find the position of a value in a list. For example I have a (define findValue x lst) which accepts a value and list and from that list I want type in (findValue 3 '(1 2 0 8 5 6)) and it should return 0 since the value in position 3 is 0. From my understanding and how it usually is position 3 would be 8 and not 0 in arrays at least. How does it work in here and how do I approach this problem?
Thanks!
Try:
(define (at n xs)
(cond ((null? xs) xs)
((= n 1) (car xs))
(else (at (- n 1) (cdr xs)))))
Use it as follows:
(at 3 '(1 2 0 8 5 6)) => 0
For zero-based indexing change the (= n 1) check on the 3rd line to (= n 0).
Edit: So you want to partially apply the at function? All you need is curry and flip. They are defined as follows:
(define (curry func . args)
(lambda x (apply func (append args x))))
(define (flip func)
(lambda (a b) (func b a)))
Using curry and flip you can now partially apply at as follows:
(define position (curry (flip at) '(1 2 0 8 5 6)))
You can now use position as follows:
(position 3) => 0
(position 4) => 8
Hope that helped.
Usually indexes are counted starting from 0, and your understanding is correct. But if you're required to implement a findValue procedure that starts counting indexes from 1, it's not that hard to write the procedure:
(define (findValue idx lst)
(cond ((or (null? lst) (negative? idx)) #f)
((= idx 1) (car lst))
(else (findValue (sub1 idx) (cdr lst)))))
Explanation:
If the list received as parameter is empty or the index becomes negative, we treat that as a special case and return #f to indicate that the value was not found
If the index is 1 then we're right where we wanted, so it's time to return the current element
Otherwise advance the recursion: subtract one from the index and advance one position over the list
It works as expected:
(findValue 3 '(1 2 0 8 5 6))
=> 0
(findValue -1 '(1 2 0 8 5 6))
=> #f
(findValue 7 '(1 2 0 8 5 6))
=> #f

Why doesn't the set! function modify the original list in Scheme (r5rs)?

I am trying to write a function which takes a list (x) and a number (y) and deletes every occurance of that number in the list. Ex. (deepdeleting '(0 0 1 2 0 3 0) 0) ===> '(1 2 3)
Here's what I have so far:
(define (deepdeleting x y)
(if (pair? x)
(if (eqv? (car x) y)
(begin
(set! x (cdr x))
(deepdeleting x y)
)
(deepdeleting (cdr x) y) ; else
)
x ; else
)
)
The code works, but my problem is I want it to modify the original list, not just return a new list. Right now this is what happens:
> (define list '(0 0 1 2 0 3 0))
> (deepdeleting list 0)
(1 2 3)
> list
(0 0 1 2 0 3 0) ; <<< I want this to be (1 2 3)
This seems strange to me since both the set-car! and set-cdr! functions seem to change the input list, whereas set! does not...
Any insight would be much appreciated!
When you use set! you are redefining the innermost binding:
(define test 10)
(set! test 11) ; changes global test to 11
(define (change-test value)
(set! test value))
(change-test 12) ; changes global test to 12
(define (change-test! value new-value)
(display value)
(set! value new-value) ; changes the local binding value
(display value))
(change-test! test 13) ; changes nothing outside of change-test, prints 12 then 13
Variable bindings are totally different than list structure mutation. Here a binding is used to point to a pair that is altered:
(define lst '(1 2 3))
(define lst2 (cdr lst)) ; lst2 shares structure with lst
(set-cdr! lst2 '(8 7 6 5))
lst2 ; ==> (2 8 7 6 5)
lst ; ==> (1 2 8 7 6 5) the original binding share structure thus is changed too
(set-cdr! lst lst) ; makes a circular never ending list (1 1 1 1 ...)
(eq? lst (cdr lst)) ;==> #t
(set-car! lst 2) ; changes lst to be never ending list (2 2 2 2 ...)
So you can mutate pairs with set-cdr! and set-car! and a binding to the original list will point to the first pair. Thus you need the result to start with the same pair as the first. With that you can make your mutating procedure this way:
#!r6rs
(import (rnrs) (rnrs mutable-pairs))
(define (remove! lst e)
(if (pair? lst)
(let loop ((prev lst)(cur (cdr lst)))
(if (pair? cur)
(if (eqv? (car cur) e)
(begin
(set-cdr! prev (cdr cur))
(loop prev (cdr cur)))
(loop cur (cdr cur)))
(if (eqv? (car lst) e)
(if (pair? (cdr lst))
(begin
(set-car! lst (cadr lst))
(set-cdr! lst (cddr lst)))
(error 'first-pair-error "Not possible to remove the first pair"))
#f)))
#f))
(define test '(0 0 1 2 0 3 0))
(define test2 (cdr test))
test2 ;==> (0 1 2 0 3 0)
(remove! test 0)
test ; ==> (1 2 3)
test2 ; ==> (0 1 2 0 3 0)
(remove! '(0) 0)
; ==> first-pair-error: Not possible to remove the first pair
(remove! '(1 2 3) 2) ; this works too but you have no way of checking
While lst is bound to the list during removal and the same list has one element less there was not binding to it outside of the remove! procedure so the result is forever lost.
EDIT
For R5RS remove the first two lines and add error:
;; won't halt the program but displays the error message
(define (error sym str)
(display str)
(newline))

Lisp Koans Scoring Project: Refactor

I am going through Lisp Koans, it's a lot of fun! But I stuck at Scoring Projects (I had a bad solution). In this project we were asked to implement a simple game called *Greed*. The problem description is here:
; *Greed* is a dice game where you roll up to five dice to accumulate
; points. The following "score" function will be used to calculate the
; score of a single roll of the dice.
;
; A greed roll is scored as follows:
; * A set of three ones is 1000 points
; * A set of three numbers (other than ones) is worth 100 times the
; number. (e.g. three fives is 500 points).
; * A one (that is not part of a set of three) is worth 100 points.
; * A five (that is not part of a set of three) is worth 50 points.
; * Everything else is worth 0 points.
;
; Examples:
;
; (score '(1 1 1 5 1)) => 1150 points
; (score '(2 3 4 6 2)) => 0 points
; (score '(3 4 5 3 3)) => 350 points
; (score '(1 5 1 2 4)) => 250 points
;
; More scoring examples are given in the tests below:
;
; Your goal is to write the score method.
My Solution is following:
WARNING! IF YOU HAVEN'T PLAY WITH THIS ONE. DO NOT SEE THIS!
I use an occurs function to calculate occurrences of number and represent in assoc-list. And a formula-wrapper function to provide correct arguments to formula function. The formula function to calculate scores. My solution is very ugly! Any advices are welcome! Thank you in advance.
(defun occurs (lst)
(let ((acc nil))
(dolist (obj lst)
(let ((p (assoc obj acc)))
(if p
(incf (cdr p))
(push (cons obj 1) acc))))
(sort acc #'> :key #'cdr)))
(defun formula-wrapper (lst)
(formula (car lst) (cdr lst)))
(defun formula (number times)
(cond ((= times 0) 0)
((= times 1)
(case number
(1 100)
(5 50)
(otherwise 0)))
((= times 2)
(case number
(1 200)
(5 100)
(otherwise 0)))
((= times 3)
(case number
(1 1000)
(otherwise (* 100 number))))
((= times 4)
(case number
(1 1100)
(5 550)
(otherwise 0)))
((= times 5)
(case number
(1 1200)
(5 600)
(otherwise 0)))
(times 0)))
(defun score (dice)
(let ((rolls (occurs dice)))
(if (null rolls)
0
(apply #'+ (mapcar #'formula-wrapper rolls))))))
The tests:
(define-test test-score-of-an-empty-list-is-zero
(assert-equal 0 (score nil)))
(define-test test-score-of-a-single-roll-of-5-is-50
(assert-equal 50 (score '(5))))
(define-test test-score-of-a-single-roll-of-1-is-100
(assert-equal 100 (score '(1))))
(define-test test-score-of-multiple-1s-and-5s-is-the-sum-of-individual-scores
(assert-equal 300 (score '(1 5 5 1))))
(define-test test-score-of-single-2s-3s-4s-and-6s-are-zero
(assert-equal 0 (score '(2 3 4 6))))
(define-test test-score-of-a-triple-1-is-1000
(assert-equal 1000 (score '(1 1 1))))
(define-test test-score-of-other-triples-is-100x
(assert-equal 200 (score '(2 2 2)))
(assert-equal 300 (score '(3 3 3)))
(assert-equal 400 (score '(4 4 4)))
(assert-equal 500 (score '(5 5 5)))
(assert-equal 600 (score '(6 6 6))))
(define-test test-score-of-mixed-is-sum
(assert-equal 250 (score '(2 5 2 2 3)))
(assert-equal 550 (score '(5 5 5 5))))
(defun score (dice)
(let ((freq (make-hash-table)))
(loop for x in dice do (incf (gethash x freq 0)))
(loop for x being the hash-key of freq using (hash-value c)
sum (if (<= 3 c)
(case x
(1 (+ 1000 (* 100 (- c 3))))
(5 (+ 500 (* 50 (- c 3))))
(t (* x 100)))
(case x
(1 (* c 100))
(5 (* c 50))
(t 0))))))
One way to write it:
(defun find-set (roll)
"which number from 1 to 6 occurs at least three times in a list of five?"
(assert (= (length roll) 5))
(loop for i from 1 to 6
when (>= (count i roll) 3)
do (return i)))
(defun score-set (i)
"compute the set score for number i"
(case i
(1 1000)
(otherwise (* i 100))))
(defun score (roll &aux (s (find-set roll)) (score 0))
(when s
(setf score (score-set s)
roll (remove s roll :count 3)))
(incf score (* (count 1 roll) 100))
(incf score (* (count 5 roll) 50))
score)
(defun test ()
(assert (= (score '(1 1 1 5 1)) 1150))
(assert (= (score '(2 3 4 6 2)) 0))
(assert (= (score '(3 4 5 3 3)) 350))
(assert (= (score '(1 5 1 2 4)) 250))
t)
A tail-recursive version:
(defun score (dice)
(labels ((iter (left ans)
(if (not left) ans
(cond ((and (>= (length left) 3)
(= (car left) (cadr left) (caddr left)))
(cond ((= (car left) 1)
(iter (cdddr left) (+ ans 1000)))
((= (car left) 5)
(iter (cdddr left) (+ ans 500)))
(t (iter (cdddr left) (+ ans (* (car left) 100))))))
((= (car left) 1) (iter (cdr left) (+ ans 100)))
((= (car left) 5) (iter (cdr left) (+ ans 50)))
(t (iter (cdr left) ans))))))
(iter (sort dice #'<) 0)))

Common Lisp: concatenate multiple values into vector

I need a function that concatenates multiple values into (simple) vector, similar to (concatenate ). However, unlike concatenate, it should be able to handle arguments that are not vectors or sequences.
I.e. it should work like this:
(concat #(1 2) 3) => #(1 2 3)
(concat 1 2 3) => #(1 2 3)
(concat 1 #(2 3 4)) => #(1 2 3 4)
(concat #(1 2) 2 #(3 4 5)) => #(1 2 3 4 5)
How can I do this? I think I've forgotten some trivial lisp construct that makes it possible.
As far as I can tell, concatenate can't do it. and I'm not quite sure how to use make it with macro (there's ,# consturct that inserts list into resulting lisp form, but but I'm not quite sure how to distinguish between non-sequences and sequences in this case).
The reduce approach in the other reply is quadratic in time.
Here is a linear solution:
(defun my-concatenate (type &rest args)
(apply #'concatenate type
(mapcar (lambda (a) (if (typep a 'sequence) a (list a)))
args)))
Since we can compute the length of the sequence, we can allocate the result sequence and then copy the elements into it.
(defun concat (type &rest items)
(let* ((len (loop for e in items
if (typep e 'sequence)
sum (length e)
else sum 1))
(seq (make-sequence type len)))
(loop with pos = 0
for e in items
if (typep e 'sequence)
do (progn
(setf (subseq seq pos) e)
(incf pos (length e)))
else
do (progn
(setf (elt seq pos) e)
(incf pos)))
seq))
CL-USER 17 > (concat 'string "abc" #\1 "def" #\2)
"abc1def2"
Above works well for vectors. A version for lists is left as an exercise.
defun my-concatenate (type &rest vectors)
(reduce (lambda (a b)
(concatenate
type
(if (typep a 'sequence) a (list a))
(if (typep b 'sequence) b (list b))))
vectors))
You can use reduce with a little modification of #'concatenate on your arguments. If one of the arguments is not a sequence, just transform it into a list (concatenate works even with mixed arguments of simple-vectors and lists).
CL-USER> (my-concatenate 'list #(1 2 3) 3 #(3 5))
(1 2 3 3 3 5)
CL-USER> (my-concatenate 'simple-vector #(1 2 3) 3 #(3 5))
#(1 2 3 3 3 5)
CL-USER> (my-concatenate 'simple-vector 1 #(2 3) (list 4 5))
#(1 2 3 4 5)
EDIT: well, you should probably accept the other answer.

Resources