Ok, I have been hacking scheme for a couple of years now, when I
have the spare time. Armed with only MacGambit and the R4RS, I
made it this far, but there's got to be a better way. (Actually,
I've moved to scsh on sever UNIX boxes. I have SCIP, Scheme and
the Art of Programming, and several good LISP books too, so it's
not really that bad.)
I include the code below, for comments, recommendations, and hints.
It does 2-D convolutions for some graphics work I'm doing...
The vector-map!, convolve!, and 2d-conv! functions seem to be more
of the scheme way to do things. 2dconv! looks a whole lot like the
way I'd do it in C, but it is a whole lot faster.
I'm pretty sure that the apply/map combo in vector-map! is producing
a lot of garbage, but I'm not sure how to get rid of it. (I suspect
a macro would solve the problem, but I have yet to get my brain
properly wrapped around macros. I understand the concepts, but
actually moving from toy examples to something from scratch is
still a bit beyond me.)
I'm also sure that the make-vector in 2d-conv! is not right. It
should be pulling that from result, not creating it on the spot,
but I haven't solved quite how to do that yet.
Finally, since I haven't had a lot of Scheme code to read, I suspect
my style is less than outstanding. Any suggestions on how to
correct that? I tried some things like some of the scsh source and
the yasos package, but with all the non r4rs'isms and macros, it's
been pretty tough going.
(I'm planning to use fps to do the output, so it will probably be
scsh code when done, however, I don't think there are any non
r4rs'isms in it right now. And no, this is not homework, but it
may turn into part of a thesis project, if I can pick up more of
the details fast enough... Yes, the code needs some comments
too...)
Jon Buller
; begin conv.scm...
(define (vector-map! result operation access . args)
(let loop ((index (- (vector-length result) 1)))
(if (< index 0)
result
(begin (vector-set! result
index
(apply operation
(let ((element (access index)))
(map (lambda (x)
(vector-ref x element))
args))))
(loop (- index 1))))))
(define (convolve! result sum prod kernel data)
(let ((offset (- (floor (/ (vector-length kernel) 2))))
(partial (make-vector (vector-length result))))
(let loop ((index (- (vector-length kernel) 1)))
(if (< index 0)
result
(begin (vector-map! result
sum
(lambda (x) x)
result
(vector-map! partial
(lambda (x)
(prod x (vector-ref kernel index)))
(lambda (x)
(modulo (+ x index offset)
(vector-length data)))
data))
(loop (- index 1)))))))
(define (2d-conv! result kernel data)
(convolve! result
(lambda (a b)
(vector-map! (make-vector (vector-length (vector-ref data 0)) 0)
+
(lambda (x) x)
a
b))
(lambda (a b)
(convolve! (make-vector (vector-length (vector-ref data 0)) 0)
+ * b a))
kernel
data))
(define (2dconv! result kernel data)
(let ((ysize (vector-length data)))
(let dyloop ((dy (- ysize 1)))
(let ((xsize (vector-length (vector-ref data dy))))
(let dxloop ((dx (- xsize 1)))
(vector-set! (vector-ref result dy) dx 0)
(let kyloop ((ky (- (vector-length kernel) 1)))
(let kxloop ((kx (- (vector-length (vector-ref kernel ky)) 1)))
(vector-set! (vector-ref result dy)
dx
(+ (vector-ref (vector-ref result dy) dx)
(* (vector-ref (vector-ref data
(modulo (+ dy ky)
ysize))
(modulo (+ dx kx) xsize))
(vector-ref (vector-ref kernel ky) kx))))
(if (not (= kx 0)) (kxloop (- kx 1))))
(if (not (= ky 0)) (kyloop (- ky 1))))
(if (not (= dx 0)) (dxloop (- dx 1)))))
(if (not (= dy 0)) (dyloop (- dy 1)) result))))
|