Mandelbrot Set implementation in Common Lisp - set

I've been working on an implementation of the Mandelbrot Set in several different languages. I have a working implementation in C++, C#, Java, and Python, but the Common Lisp implementation has some bugs that I just can't figure out. It generates the set but somewhere in the pipeline the set gets distorted. I've tested and know with near certainty that the file I/O CLO isn't the problem - it's unlikely but possible, I've tested it pretty thoroughly.
Note that the intent of these implementations is to benchmark them against one another - so I'm trying to keep the code implementations as similar as possible so they are comparable.
The Mandelbrot set (here generated by the Python implementation):
"Mandelbrot Set (Generated by Python)"
But my Common Lisp program generates this:
"Common Lisp version's Distorted Mandelbrot Set"
The bug is identical in both Clisp and SBCL.
CODE:
Common Lisp:
(defun mandelbrot (real cplx num_iter)
(if (> (+ (* real real) (* cplx cplx)) 4)
1
(let ((tmpreal real) (tmpcplx cplx) (i 1))
(loop
(setq tmpcplx (+ (* (* tmpreal tmpcplx) 2) cplx))
(setq tmpreal (+ (- (* tmpreal tmpreal) (* tmpcplx tmpcplx))
real))
(setq i (+ i 1))
(cond
((> (+ (* tmpreal tmpreal)
(* tmpcplx tmpcplx)) 4) (return i))
((= i num_iter) (return 0)))))))
(defun floordiv (dend sor) (/ (- dend (mod dend sor)) sor))
(defclass xbm () (
(data :accessor data :initarg :data)
(dim :reader dim :initarg :dim)
(arrsize :reader arrsize :initarg :arrsize)))
(defmethod width ((self xbm)) (third (dim self)))
(defmethod height ((self xbm)) (second (dim self)))
(defun generate (width height)
(let ((dims (list 0 0 0)) (arrsize_tmp 0))
(setq dims (list 0 0 0))
(setf (second dims) height)
(setf (third dims) width)
(setf (first dims) (floordiv (third dims) 8))
(unless (= (mod width 8) 0) (setf (first dims) (+ (first dims) 1)))
(setq arrsize_tmp (* (first dims) (second dims)))
(make-instance 'xbm
:data (make-array arrsize_tmp :initial-element 0)
:dim dims
:arrsize arrsize_tmp)))
(defun writexbm (self f)
(with-open-file (stream f :direction :output :if-exists :supersede)
(let ((fout stream))
(format fout "#define mandelbrot_width ~d~&" (width self))
(format fout "#define mandelbrot_height ~d~&" (height self))
(format fout "#define mandelbrot_x_hot 1~&")
(format fout "#define mandelbrot_y_hot 1~&")
(format fout "static char mandelbrot_bits[] = {")
(let ((i 0))
(loop
(if (= (mod i 8) 0)
(format fout "~& ")
(format fout " "))
(format fout "0x~x," (svref (data self) i))
(unless (< (setf i (+ i 1)) (arrsize self))
(return t)))))))
(defmethod setpixel ((self xbm) (x integer) (y integer))
(if (and (< x (third (dim self))) (< y (second (dim self))))
(let ((val (+ (floordiv x 8) (* y (first (dim self))))))
(setf (svref (data self) val) (boole boole-ior (svref (data self) val) (ash 1 (mod x 8)))))))
(defmethod unsetpixel ((self xbm) (x integer) (y integer))
(if (and (< x (third (dim self))) (< y (second (dim self))))
(let ((val (+ (floordiv x 8) (* y (first (dim self))))))
(setf (svref (data self) val) (boole boole-xor (boole boole-ior
(svref (data self) val) (ash 1 (mod x 8))) (ash 1 (mod x 8)))))))
(defmethod draw_mandelbrot ((xbm xbm) (num_iter integer) (xmin number)
(xmax number) (ymin number) (ymax number))
(let ((img_width (width xbm)) (img_height (height xbm)) (xp 0))
(loop
(if (< xp img_width)
(let ((xcoord (+ (* (/ xp img_width) (- xmax xmin)) xmin)) (yp 0))
(loop
(if (< yp img_height)
(let (
(ycoord (+ (* (/ yp img_height) (- ymax ymin)) ymin)))
(let ((val (mandelbrot xcoord ycoord num_iter)))
(if (> val 0) (unsetpixel xbm xp yp) (setpixel xbm xp yp)))
(setq yp (+ yp 1)))
(return 0)))
(setq xp (+ xp 1)))
(return 0)))))
(defun main ()
(let ((maxiter 0) (xmin 0) (xmax 0) (ymin 0) (ymax 0) (file nil) (xsize 0) (ysize 0) (picture nil))
(format t "maxiter? ")
(setq maxiter (read))
(format t "xmin? ")
(setq xmin (read))
(format t "xmax? ")
(setq xmax (read))
(format t "ymin? ")
(setq ymin (read))
(format t "ymax? ")
(setq ymax (read))
(format t "file path: ")
(setq file (read-line))
(format t "picture width? ")
(setq xsize (read))
(format t "picture height? ")
(setq ysize (read))
(format t "~&")
(setq picture (generate xsize ysize))
(draw_mandelbrot picture maxiter xmin xmax ymin ymax)
(writexbm picture file)
(format t "File Written.")
0))
(main)
And the closest to it is Python:
from xbm import *
def mandelbrot(real_old,cplx_old,i):
real = float(real_old)
cplx = float(cplx_old)
if (real*real+cplx*cplx) > 4:
return 1
tmpreal = real
tmpcplx = cplx
for rep in range(1,i):
tmpb = tmpcplx
tmpcplx = tmpreal*tmpcplx*2
tmpreal = tmpreal*tmpreal - tmpb*tmpb
tmpcplx += cplx
tmpreal += real
tmpb = tmpcplx*tmpcplx + tmpreal*tmpreal
if tmpb > 4:
return rep+1
else:
return 0
def draw_mandelbrot(pic, num_iter, xmin, xmax, ymin, ymax):
img_width = pic.width()
img_height = pic.height()
for xp in range(img_width):
xcoord = (((float(xp)) / img_width) * (xmax - xmin)) + xmin
for yp in range(img_height):
ycoord = (((float(yp)) / img_height) * (ymax - ymin)) + ymin
val = mandelbrot(xcoord, ycoord, num_iter)
if (val):
pic.unsetpixel(xp, yp)
else:
pic.setpixel(xp, yp)
def main():
maxiter = int(raw_input("maxiter? "))
xmin = float(raw_input("xmin? "))
xmax = float(raw_input("xmax? "))
ymin = float(raw_input("ymin? "))
ymax = float(raw_input("ymax? "))
file = raw_input("file path: ")
xsize = int(raw_input("picture width? "))
ysize = int(raw_input("picture height? "))
print
picture = xbm(xsize, ysize)
draw_mandelbrot(picture, maxiter, xmin, xmax, ymin, ymax)
picture.writexbm(file)
print "File Written. "
return 0;
main()
[xbm.py]
from array import *
class xbm:
def __init__(self, width, height):
self.dim = [0, 0, 0]
self.dim[1] = height
self.dim[2] = width
self.dim[0] = self.dim[2] / 8
if width % 8 != 0:
self.dim[0] += 1
self.arrsize = self.dim[0] * self.dim[1]
self.data = array('B', (0 for x in range(self.arrsize)))
self.hex = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f']
def __nibbletochar__(self, a):
if a < 0 or a > 16:
return '0'
else:
return self.hex[a]
def setpixel(self, x, y):
if x < self.dim[2] and y < self.dim[1]:
self.data[(x / 8) + (y * self.dim[0])] |= 1 << (x % 8)
def unsetpixel(self, x, y):
if x < self.dim[2] and y < self.dim[1]:
self.data[(x / 8) + (y * self.dim[0])] |= 1 << (x % 8)
self.data[(x / 8) + (y * self.dim[0])] ^= 1 << (x % 8)
def width(self):
return self.dim[2]
def height(self):
return self.dim[1]
def writexbm(self, f):
fout = open(f, 'wt')
fout.write("#define mandelbrot_width ")
fout.write(str(self.dim[2]))
fout.write("\n#define mandelbrot_height ")
fout.write(str(self.dim[1]))
fout.write("\n#define mandelbrot_x_hot 1")
fout.write("\n#define mandelbrot_y_hot 1")
fout.write("\nstatic char mandelbrot_bits[] = {")
for i in range(self.arrsize):
if (i % 8 == 0): fout.write("\n\t")
else: fout.write(" ")
fout.write("0x")
fout.write(self.__nibbletochar__(((self.data[i] >> 4) & 0x0F)))
fout.write(self.__nibbletochar__((self.data[i] & 0x0F)))
fout.write(",")
fout.write("\n};\n")
fout.close();
I can post the C++, C#, or Java code as well need be.
Thanks!
EDIT: Thanks to Edmund's response i found the bug- Just something that slipped through the cracks on porting. Modified code:
(defun mandelbrot (real cplx num_iter)
(if (> (+ (* real real) (* cplx cplx)) 4)
1
(let ((tmpreal real) (tmpcplx cplx) (i 1) (tmpb cplx))
(loop
(setq tmpb tmpcplx)
(setq tmpcplx (+ (* (* tmpreal tmpcplx) 2) cplx))
(setq tmpreal (+ (- (* tmpreal tmpreal) (* tmpb tmpb))
real))
(setq i (+ i 1))
(cond
((> (+ (* tmpreal tmpreal)
(* tmpcplx tmpcplx)) 4) (return i))
((= i num_iter) (return 0)))))))
(defun floordiv (dend sor) (/ (- dend (mod dend sor)) sor))
(defclass xbm () (
(data :accessor data :initarg :data)
(dim :reader dim :initarg :dim)
(arrsize :reader arrsize :initarg :arrsize)))
(defun width (self) (third (dim self)))
(defun height (self) (second (dim self)))
(defun generate (width height)
(let ((dims (list 0 0 0)) (arrsize_tmp 0))
(setq dims (list 0 0 0))
(setf (second dims) height)
(setf (third dims) width)
(setf (first dims) (floordiv (third dims) 8))
(unless (= (mod width 8) 0) (setf (first dims) (+ (first dims) 1)))
(setq arrsize_tmp (* (first dims) (second dims)))
(make-instance 'xbm
:data (make-array arrsize_tmp :initial-element 0)
:dim dims
:arrsize arrsize_tmp)))
(defun writexbm (self f)
(with-open-file (stream f :direction :output :if-exists :supersede)
(let ((fout stream))
(format fout "#define mandelbrot_width ~d~&" (width self))
(format fout "#define mandelbrot_height ~d~&" (height self))
(format fout "#define mandelbrot_x_hot 1~&")
(format fout "#define mandelbrot_y_hot 1~&")
(format fout "static char mandelbrot_bits[] = {")
(let ((i 0))
(loop
(if (= (mod i 8) 0)
(format fout "~& ")
(format fout " "))
(format fout "0x~x," (svref (data self) i))
(unless (< (setf i (+ i 1)) (arrsize self))
(return t)))))))
(defun setpixel (self x y)
(if (and (< x (third (dim self))) (< y (second (dim self))))
(let ((val (+ (floordiv x 8) (* y (first (dim self))))))
(setf (svref (data self) val) (boole boole-ior (svref (data self) val) (ash 1 (mod x 8)))))))
(defun unsetpixel (self x y)
(if (and (< x (third (dim self))) (< y (second (dim self))))
(let ((val (+ (floordiv x 8) (* y (first (dim self))))))
(setf (svref (data self) val) (boole boole-xor (boole boole-ior
(svref (data self) val) (ash 1 (mod x 8))) (ash 1 (mod x 8)))))))
(defun draw_mandelbrot (xbm num_iter xmin xmax ymin ymax)
(let ((img_width (width xbm)) (img_height (height xbm)) (xp 0))
(loop
(if (< xp img_width)
(let ((xcoord (+ (* (/ xp img_width) (- xmax xmin)) xmin)) (yp 0))
(loop
(if (< yp img_height)
(let (
(ycoord (+ (* (/ yp img_height) (- ymax ymin)) ymin)))
(let ((val (mandelbrot xcoord ycoord num_iter)))
(if (> val 0) (unsetpixel xbm xp yp) (setpixel xbm xp yp)))
(setq yp (+ yp 1)))
(return 0)))
(setq xp (+ xp 1)))
(return 0)))))
(defun main ()
(let ((maxiter 0) (xmin 0) (xmax 0) (ymin 0) (ymax 0) (file nil) (xsize 0) (ysize 0) (picture nil))
(format t "maxiter? ")
(setq maxiter (read))
(format t "xmin? ")
(setq xmin (read))
(format t "xmax? ")
(setq xmax (read))
(format t "ymin? ")
(setq ymin (read))
(format t "ymax? ")
(setq ymax (read))
(format t "file path: ")
(setq file (read-line))
(format t "picture width? ")
(setq xsize (read))
(format t "picture height? ")
(setq ysize (read))
(format t "~&")
(setq picture (generate xsize ysize))
(draw_mandelbrot picture maxiter xmin xmax ymin ymax)
(writexbm picture file)
(format t "File Written.")
0))
(main)
Though the code isn't very LISP-ish (is that a word?) it works. Thanks to all who posted/commented/answered :)

Some remarks about your code:
mandelbrot: lacks declarations, squares are computed twice in the loop
mandelbrot: in the computation for TMPREAL you are using the new value of TMPCLX, not the old one
You don't want to use METHODS to set pixels. SLOW.
FLOORDIV is one of FLOOR or TRUNCATE (depending on what you want) in Common Lisp, see (FLOOR 10 3)
use type declarations
in writexbm don't repeatedly call DATA and ARRSIZE
setpixel, unsetpixel looks very expensive, again repeatedly dereferencing the structure
draw-mandelbrot has a lot of repeated computations that can be done once
Common Lisp has 2d arrays which simplify the code
Common Lisp has complex numbers, which also simplify the code
a variable name 'self' makes no sense in Common Lisp. Name it to what it is.
Generally the code is full of waste. It makes little sense to benchmark your code, since it is written in a style that hopefully nobody uses in Common Lisp. Common Lisp has been designed with experience of large mathematical software like Macsyma and allows to write mathematical code in a straight forward way (no objects, just functions over numbers, arrays, ...). The better compilers can take advantage of primitive types, primitive operations and type declarations. Thus the style is different from what one might write in Python (which usually either is object-oriented Python or calls to some C code) or Ruby. In heavy numerical code it is usually not a good idea to have dynamic dispatch like with CLOS. Setting pixels in bitmaps via CLOS calls in a tight LOOP is really something one wants to avoid (unless you know how to optimize it).
The better Lisp compilers will compile the numeric functions to direct machine code. During the compilation they give hints which operations are generic and can't be optimized (until the developer adds more type information). The developer can also 'DISASSEMBLE' the functions and check for code that is generic or does unnecessary function calls. "TIME' gives runtime information and also informs the developer about the amount of memory 'consed'. In numeric code consing of 'floats' is a usual performance problem.
So, to sum up:
if you write code and think that it does the same in different languages, when the code looks similar or has a similar structure, this might not be the case - unless you really know both languages and both language implementations.
if you write code in one language and port it in a similar style to a different language, you may miss a whole existing culture to write solutions to these kinds of problems in a different way. For example one can write code in C++ in an object-oriented style and port it in a similar way to FORTRAN. But no one writes such code in FORTRAN. Written in FORTRAN style, will typically result in faster code - especially since the compilers are heavily optimized for idiomatic FORTRAN code.
"when in rome, speak like the romans"
Example:
in SETPIXEL there is a call to (first (dim self)). Why not make that value a slot in the structure in the first place, instead of doing a list access all the time?
But then the value is constant during the computation. Still the structure is passed, and the value is retrieved all the time. Why not just get the value outside the main loop and pass it directly? Instead of doing multiple computations of it?
To give you an idea how code might be written (with type declarations, loops, complex numbers, ...), here is a slightly different version of the mandelbrot computation.
The core algorithm:
(defvar *num-x-cells* 1024)
(defvar *num-y-cells* 1024)
(defvar *depth* 60)
(defun m (&key (left -1.5) (top -1.0) (right 0.5) (bottom 1.0) (depth *depth*))
(declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
(loop with delta-x-cell float = (/ (- right left) *num-x-cells*)
and delta-y-cell float = (/ (- bottom top) *num-y-cells*)
and field = (make-array (list *num-x-cells* *num-y-cells*))
for ix fixnum below *num-x-cells*
for x float = (+ (* (float ix) delta-x-cell) left)
do (loop for iy fixnum below *num-y-cells*
for y = (+ (* (float iy) delta-y-cell) top)
do (loop for i fixnum below depth
for z of-type complex = (complex x y)
then (+ (complex x y) (* z z))
for exit = (> (+ (* (realpart z) (realpart z))
(* (imagpart z) (imagpart z)))
4)
finally (setf (aref field ix iy) i)
until exit))
finally (return field)))
Above function returns a 2d array of numbers.
Writing an xbm file:
(defun writexbm (array pathname &key (black *depth*))
(declare (fixnum black)
(optimize (speed 3) (safety 2) (debug 0) (space 0)))
(with-open-file (stream pathname :direction :output :if-exists :supersede)
(format stream "#define mandelbrot_width ~d~&" (array-dimension array 0))
(format stream "#define mandelbrot_height ~d~&" (array-dimension array 1))
(format stream "#define mandelbrot_x_hot 1~&")
(format stream "#define mandelbrot_y_hot 1~&")
(format stream "static char mandelbrot_bits[] = {")
(loop for j fixnum below (array-dimension array 1) do
(loop for i fixnum below (truncate (array-dimension array 0) 8)
for m fixnum = 0 then (mod (1+ m) 8) do
(when (zerop m) (terpri stream))
(format stream "0x~2,'0x, "
(let ((v 0))
(declare (fixnum v))
(dotimes (k 8 v)
(declare (fixnum k))
(setf v (logxor (ash (if (= (aref array
(+ (* i 8) k) j)
black)
1 0)
k)
v)))))))
(format stream "~&}~&")))
Above function takes an array and a pathname and writes the array as XBM file.
One number 'black' will be 'black' and the other numbers are 'white'
Call
(writexbm (m) "/tmp/m.xbm")

I'm not sure this part is correct:
(setq tmpcplx (+ (* (* tmpreal tmpcplx) 2) cplx))
(setq tmpreal (+ (- (* tmpreal tmpreal) (* tmpcplx tmpcplx))
real))
Isn't tempcplx being overwritten with its new value on the first line, meaning that the second line is using the new value, not the original one?
In the Python version you're avoiding this problem by using tmpb:
tmpb = tmpcplx
tmpcplx = tmpreal*tmpcplx*2
tmpreal = tmpreal*tmpreal - tmpb*tmpb
tmpcplx += cplx
tmpreal += real
It seems to me the Lisp version should do something similar, i.e. store the original value of tmpcplx first, and use that store for the calculation of tmpreal:
(setq tmpb cplx)
(setq tmpcplx (+ (* (* tmpreal tmpcplx) 2) cplx))
(setq tmpreal (+ (- (* tmpreal tmpreal) (* tmpb tmpb))
real))

Related

How do I customize the printing of a procedure in Racket?

Suppose I used the following procedures to implement a primitive class:
;;; Constructor.
(define (make-pos x y)
(lambda (msg)
(cond [(eq? msg 'get-x) x]
[(eq? msg 'get-y) y]
[(eq? msg 'set-x) (lambda (v) (set! x v))]
[(eq? msg 'set-y) (lambda (v) (set! y v))]
[else (error "POS invalid msg" msg)])))
;;; Getters and setters.
(define (pos-x pos) (pos 'get-x))
(define (pos-y pos) (pos 'get-y))
(define (set-pos-x! pos x) ((pos 'set-x) x))
(define (set-pos-y! pos y) ((pos 'set-y) y))
I know that Racket has an object system, but I am making this just for educational purposes. My problem is: how do I customize the printing/displaying of a procedure? For example:
(define mypos (make-pos 1 2))
(displayln mypos)
This displays something like #<procedure:...xxx/test.rkt:4:2>, which is not ideal. Is there a way to customize the output?
EDIT: I would like (displayln mypos) to display (POS (x 1) (y 2)).
There are 3 ways:
statically naming the lambda
dynamically naming the procedure
making a struct with prop:procedure
Method (1) is very limited, where you can change #<procedure:...xxx/test.rkt:4:2> to #<procedure:my-constant-name> by naming the lambda:
(define my-constant-name
(lambda (msg) ....))
my-constant-name
; #<procedure:my-constant-name>
Method (2) using procedure-rename lets you change the name dynamically, but it doesn't let you get rid of the #<procedure > part:
(procedure-rename
(lambda (msg) ....)
'my-new-name)
; #<procedure:my-new-name>
Method (3) using a struct is more powerful. It lets you change the printing to anything you want:
(struct proc/print [proc print]
#:property prop:procedure (struct-field-index proc)
#:methods gen:custom-write
[(define (write-proc self out mode)
((proc/print-print self) out))])
(proc/print
(lambda (msg) ....)
(lambda (out)
(display "whatever you want" out)))
; whatever you want
If you want to display the s-expression representation of the lambda, you can do that:
(struct proc/sexpr [proc sexpr]
#:property prop:procedure (struct-field-index proc)
#:methods gen:custom-write
[(define (write-proc self out mode)
(write (proc/sexpr-sexpr self) out))])
(define-simple-macro (lam stuff ...)
(proc/sexpr (lambda stuff ...) '(lam stuff ...)))
(lam (msg) ....)
; (lam (msg) ....)
Update: displaying (POS (x 1) (y 2))
Using method (3) and a proc/get-sexpr struct (like the proc/sexpr struct above but with an extra lambda), you can get it to display as (POS (x 1) (y 2)) like this:
(struct proc/get-sexpr [proc get-sexpr]
#:property prop:procedure (struct-field-index proc)
#:methods gen:custom-write
[(define (write-proc self out mode)
(write ((proc/get-sexpr-get-sexpr self)) out))])
(define (make-pos x y)
(proc/get-sexpr
(lambda (msg)
(cond [(eq? msg 'get-x) x]
[(eq? msg 'get-y) y]
[(eq? msg 'set-x) (lambda (v) (set! x v))]
[(eq? msg 'set-y) (lambda (v) (set! y v))]
[else (error "POS invalid msg" msg)]))
(lambda () `(POS (x ,x) (y ,y)))))
;;; Getters and setters.
(define (pos-x pos) (pos 'get-x))
(define (pos-y pos) (pos 'get-y))
(define (set-pos-x! pos x) ((pos 'set-x) x))
(define (set-pos-y! pos y) ((pos 'set-y) y))
Using that, calling (make-pos 1 2) produces a value that displays as (POS (x 1) (y 2)).
> (define x (make-pos 1 2))
> x
(POS (x 1) (y 2))
> ((x 'set-x) 10)
> x
(POS (x 10) (y 2))

Efficient implementation of Damerau-Levenshtein distance

I'm trying to implement really efficient Clojure function to compute Damerau-Levenshtein distance. I've decided to use this algorithm (attached source should be C++) for computing Levenshtein distance and add some lines to make it work for DLD.
Here is what I've created in Common Lisp (I hope it could help):
(defun damerau-levenshtein (x y)
(declare (type string x y)
#.*std-opts*)
(let* ((x-len (length x))
(y-len (length y))
(v0 (apply #'vector (mapa-b #'identity 0 y-len)))
(v1 (make-array (1+ y-len) :element-type 'integer))
(v* (make-array (1+ y-len) :element-type 'integer)))
(do ((i 0 (1+ i)))
((= i x-len) (aref v0 y-len))
(setf (aref v1 0) (1+ i))
(do ((j 0 (1+ j)))
((= j y-len))
(let* ((x-i (char x i))
(y-j (char y j))
(cost (if (char-equal x-i y-j) 0 1)))
(setf (aref v1 (1+ j)) (min (1+ (aref v1 j))
(1+ (aref v0 (1+ j)))
(+ (aref v0 j) cost)))
(when (and (plusp i) (plusp j))
(let ((x-i-1 (char x (1- i)))
(y-j-1 (char y (1- j)))
(val (+ (aref v* (1- j)) cost)))
(when (and (char-equal x-i y-j-1)
(char-equal x-i-1 y-j)
(< val (aref v1 (1+ j))))
(setf (aref v1 (1+ j)) val))))))
(rotatef v* v0 v1))))
Now, I fear I cannot translate it into really efficient and idiomatic Clojure code (in functional style?). I would really appreciate any suggestion and I think it may be quite useful for many future readers too.
P.S. I've found this implementation, but I doubt if it is efficient and it uses some obsolete contrib functions (deep-merge-with and bool-to-binary):
(defn damerau-levenshtein-distance
[a b]
(let [m (count a)
n (count b)
init (apply deep-merge-with (fn [a b] b)
(concat
;;deletion
(for [i (range 0 (+ 1 m))]
{i {0 i}})
;;insertion
(for [j (range 0 (+ 1 n))]
{0 {j j}})))
table (reduce
(fn [d [i j]]
(deep-merge-with
(fn [a b] b)
d
(let [cost (bool-to-binary (not (= (nth a (- i 1))
(nth b (- j 1)))))
x
(min
(+ ((d (- i 1))
j) 1) ;;deletion
(+ ((d i)
(- j 1)) 1) ;;insertion
(+ ((d (- i 1))
(- j 1)) cost)) ;;substitution))
val (if (and (> i 1)
(> j 1)
(= (nth a (- i 1))
(nth b (- j 2)))
(= (nth a (- i 2))
(nth b (- j 1))))
(min x (+ ((d (- i 2))
(- j 2)) ;;transposition
cost))
x)]
{i {j val}})))
init
(for [j (range 1 (+ 1 n))
i (range 1 (+ 1 m))] [i j]))]
((table m) n)))
I recently had to write an efficient levenshtein distance function in clojure to calculate the edits between a ground truth text and a ocr engine result.
The recursive implementation wasn't performant enough to quickly calculate the levenshtein distance between two whole pages, so my implementation uses dynamic programming.
Instead of dropping down to java 2d-arrays it uses core.matrix to handle the matrix stuff.
Adding the transposition stuff for damerau-levenshtein should not be hard.
(defn lev [str1 str2]
(let [mat (new-matrix :ndarray (inc (count str1)) (inc (count str2)))
len1 (count str1) len2 (count str2)]
(mset! mat 0 0 0)
(dotimes [i lein1]
(mset! mat (inc i) 0 (inc i)))
(dotimes [j len2]
(mset! mat 0 (inc j) (inc j)))
(dotimes [dj len2]
(dotimes [di len1]
(let [j (inc dj) i (inc di)]
(mset! mat i j
(cond
(= (.charAt ^String str1 di) (.charAt ^String str2 dj))
(mget mat di dj)
:else
(min (inc (mget mat di j)) (inc (mget mat i dj))
(inc (mget mat di dj))))))))
(mget mat len1 len2))))
Hope this helps
OK, this should do the trick (based on KIMA's answer):
(defn da-lev [str1 str2]
(let [l1 (count str1)
l2 (count str2)
mx (new-matrix :ndarray (inc l1) (inc l2))]
(mset! mx 0 0 0)
(dotimes [i l1]
(mset! mx (inc i) 0 (inc i)))
(dotimes [j l2]
(mset! mx 0 (inc j) (inc j)))
(dotimes [i l1]
(dotimes [j l2]
(let [i+ (inc i) j+ (inc j)
i- (dec i) j- (dec j)
cost (if (= (.charAt str1 i)
(.charAt str2 j))
0 1)]
(mset! mx i+ j+
(min (inc (mget mx i j+))
(inc (mget mx i+ j))
(+ (mget mx i j) cost)))
(if (and (pos? i) (pos? j)
(= (.charAt str1 i)
(.charAt str2 j-))
(= (.charAt str1 i-)
(.charAt str2 j)))
(mset! mx i+ j+
(min (mget mx i+ j+)
(+ (mget mx i- j-) cost)))))))
(mget mx l1 l2)))
Please note that you need core.matrix library, which is not standard (despite its name). One can install it with Leiningen this way:
[net.mikera/core.matrix "0.29.1"]
The library lives in namespace clojure.core.matrix. To use this solution 'as is' you should 'add' symbols from the namespace into your namespace.

In scheme I keep getting "Error: ( : 1) car: argument 1 must be: pair", why?

I found this page explaining that some of the gimp functions won't return values consistently, so I implemented a do while loop to make sure the functions are returning pairs before using car. Still, I get the error Error: ( : 1) car: argument 1 must be: pair, but I'm not sure how that's possible as it should keep running the function until it returns a pair.
(define (script-fu-scratchpad drawable)
(let* ((imgHeight 0)
(imgWidth)
(bpp)
(pixel))
(set! imgHeight (gimp-drawable-height drawable))
(do ()
[(pair? imgHeight)]
(set! imgHeight (gimp-drawable-height drawable)))
(set! imgHeight (car imgHeight))
(set! imgWidth (gimp-drawable-width drawable))
(do ()
[(pair? imgWidth)]
(set! imgWidth (gimp-drawable-width drawable)))
(set! imgWidth (car imgWidth))
(set! bpp (gimp-drawable-bpp drawable))
(do ()
[(pair? bpp)]
(set! bpp (gimp-drawable-bpp drawable)))
(set! bpp (car bpp))
(display bpp) (newline)
(set! pixel (cons-array bpp 'byte))
(aset pixel 0 150)
(aset pixel 1 150)
(aset pixel 2 150)
(aset pixel 3 0)
(gimp-drawable-set-pixel drawable (/ imgHeight 2) (/ imgWidth 2) bpp pixel)
(gimp-context-set-background '(100 100 100))
(define county 0)
(define countx 0)
(do ()
[(= countx imgWidth)]
(do ()
[(= county imgHeight)]
(gimp-drawable-set-pixel drawable county countx bpp pixel)
(set! county (+ county 1)))
(set! countx (+ countx 1)))))
In response to GoZoner, I edited it and received the following error: Error: (:1) car: argument 1 must be: pair
(define
(script-fu-scratchpad drawable)
(let*
(
(imgHeight 0)
(imgWidth 0)
(bpp 0)
(pixel 0)
)
(set! imgHeight (gimp-drawable-height drawable))
(set! imgWidth (gimp-drawable-width drawable))
(set! bpp (gimp-drawable-bpp drawable))
(do ()
[(pair? bpp)]
(set! bpp (gimp-drawable-bpp drawable))
)
(set! bpp (car bpp))
(display bpp) (newline)
(set! pixel (cons-array bpp 'byte))
(aset pixel 0 150)
(aset pixel 1 150)
(aset pixel 2 150)
(aset pixel 3 0)
(gimp-drawable-set-pixel drawable (/ imgHeight 2) (/ imgWidth 2) bpp pixel)
(gimp-context-set-background '(100 100 100))
(define county 0)
(define countx 0)
(do ()
[(= countx imgWidth)]
(do ()
[(= county imgHeight)]
(gimp-drawable-set-pixel drawable county countx bpp pixel)
(set! county (+ county 1))
)
(set! countx (+ countx 1))
)
)
)
A couple of things.
In your highest level let* you should be initializing each of the
variables rather than just imgHeight or none of them. Actual
Scheme requires all to be initialized.
Based on name along, I wouldn't expect (gimp-drawable-height drawable) to return a list/cons; it should return a height as a number. Therefore:
I can't imagine (pair? imgHeight) would ever be true
I would expect (car imgHeight) to fail - and it apparently has based on the error you've reported.
The function aset is presumably acting on a multidimensional ((>= rank 2)) array. Therefore its 'index' argument ought to have more then just a single integer. But, perhaps aset is just simply vector-ref in GIMP's scripting variant.
[EDIT: to be more specific] I've annotated your code
(set! bpp (gimp-drawable-bpp drawable)) ; bpp is NOT a pair
(do ()
[(pair? bpp)] ; bpp is NOT a pair
(set! bpp (gimp-drawable-bpp drawable)))
(set! bpp (car bpp)) ; bpp is NOT a pair => ERROR

Can this function be simplified (made more "fast")?

I was wondering if this is the fastest possible version of this function.
(defun foo (x y)
(cond
;if x = 0, return y+1
((zp x) (+ 1 y))
;if y = 0, return foo on decrement x and 1
((zp y) (foo (- x 1) 1))
;else run foo on decrement x and y = (foo x (- y 1))
(t (foo (- x 1) (foo x (- y 1))))))
When I run this, I usually get stack overflow error, so I am trying to figure out a way to compute something like (foo 3 1000000) without using the computer.
From analyzing the function I think it is embedded foo in the recursive case that causes the overflow in (foo 3 1000000). But since you are decrementing y would the number of steps just equal y?
edit: removed lie from comments
12 years ago I wrote this:
(defun ackermann (m n)
(declare (fixnum m n) (optimize (speed 3) (safety 0)))
(let ((memo (make-hash-table :test #'equal))
(ncal 0) (nhit 0))
(labels ((ack (aa bb)
(incf ncal)
(cond ((zerop aa) (1+ bb))
((= 1 aa) (+ 2 bb))
((= 2 aa) (+ 3 (* 2 bb)))
((= 3 aa) (- (ash 1 (+ 3 bb)) 3))
((let* ((key (cons aa bb))
(val (gethash key memo)))
(cond (val (incf nhit) val)
(t (setq val (if (zerop bb)
(ack (1- aa) 1)
(ack (1- aa) (ack aa (1- bb)))))
(setf (gethash key memo) val)
val)))))))
(let ((ret (ack m n)))
(format t "A(~d,~d)=~:d (~:d calls, ~:d cache hits)~%"
m n ret ncal nhit)
(values ret memo)))))
As you can see, I am using an explicit formula for small a and memoization for larger a.
Note, however, that this function grows so fast that it makes little sense to try to compute the actual values; you will run out of atoms in the universe faster - memoization or not.
Conceptually speaking, stack overflows don't have anything to do with speed, but they concern space usage. For instance, consider the following implementations of length. The first will run into a stack overflow for long lists. The second will too, unless your Lisp implements tail call optimization. The third will not. All have the same time complexity (speed), though; they're linear in the length of the list.
(defun length1 (list)
(if (endp list)
0
(+ 1 (length1 (rest list)))))
(defun length2 (list)
(labels ((l2 (list len)
(if (endp list)
len
(l2 (rest list) (1+ len)))))
(l2 list 0)))
(defun length3 (list)
(do ((list list (rest list))
(len 0 (1+ len)))
((endp list) len)))
You can do something similar for your code, though you'll still have one recursive call that will contribute to stack space. Since this does appear to be the Ackermann function, I'm going to use zerop instead of zp and ack instead of foo. Thus, you could do:
(defun foo2 (x y)
(do () ((zp x) (+ 1 y))
(if (zp y)
(setf x (1- x)
y 1)
(psetf x (1- x)
y (foo x (1- y))))))
Since x is decreasing by 1 on each iteration, and the only conditional change is on y, you could simplify this as:
(defun ack2 (x y)
(do () ((zerop x) (1+ y))
(if (zerop y)
(setf x (1- x)
y 1)
(psetf x (1- x)
y (ack2 x (1- y))))))
Since y is the only thing that conditionally changes during iterations, you could further simplify this to:
(defun ack3 (x y)
(do ((x x (1- x))
(y y (if (zerop y) 1 (ack3 x (1- y)))))
((zerop x) (1+ y))))
This is an expensive function to compute, and this will get you a little bit farther, but you're still not going to get, e.g., to (ackN 3 1000000). All these definitions are available for easy copying and pasting from http://pastebin.com/mNA9TNTm.
Generally, memoization is your friend in this type of computation. Might not apply as it depends on the specific arguments in the recursion; but it is a useful approach to explore.

Miller-Rabin Scheme implementation unpredictable output

I am new to Scheme. I have tried and implemented probabilistic variant of Rabin-Miller algorithm using PLT Scheme. I know it is probabilistic and all, but I am getting the wrong results most of the time. I have implemented the same thing using C, and it worked well (never failed a try). I get the expected output while debugging, but when I run, it almost always returns with an incorrect result. I used the algorithm from Wikipedia.
(define expmod( lambda(b e m)
;(define result 1)
(define r 1)
(let loop()
(if (bitwise-and e 1)
(set! r (remainder (* r b) m)))
(set! e (arithmetic-shift e -1))
(set! b (remainder (* b b) m))
(if (> e 0)
(loop)))r))
(define rab_mil( lambda(n k)
(call/cc (lambda(breakout)
(define s 0)
(define d 0)
(define a 0)
(define n1 (- n 1))
(define x 0)
(let loop((count 0))
(if (=(remainder n1 2) 0)
(begin
(set! count (+ count 1))
(set! s count)
(set! n1 (/ n1 2))
(loop count))
(set! d n1)))
(let loop((count k))
(set! a (random (- n 3)))
(set! a (+ a 2))
(set! x (expmod a d n))
(set! count (- count 1))
(if (or (= x 1) (= x (- n 1)))
(begin
(if (> count 0)(loop count))))
(let innerloop((r 0))
(set! r (+ r 1))
(if (< r (- s 1)) (innerloop r))
(set! x (expmod x 2 n))
(if (= x 1)
(begin
(breakout #f)))
(if (= x (- n 1))
(if (> count 0)(loop count)))
)
(if (= x (- s 1))
(breakout #f))(if (> count 0) (loop count)))#t))))
Also, Am I programming the right way in Scheme? (I am not sure about the breaking out of loop part where I use call/cc. I found it on some site and been using it ever since.)
Thanks in advance.
in general you are programming in a too "imperative" fashion; a more elegant expmod would be
(define (expmod b e m)
(define (emod b e)
(case ((= e 1) (remainder b m))
((= (remainder e 2) 1)
(remainder (* b (emod b (- e 1))) m)
(else (emod (remainder (* b b) m) (/ e 2)))))))
(emod b e))
which avoids the use of set! and just implements recursively the rules
b^1 == b (mod m)
b^k == b b^(k-1) (mod m) [k odd]
b^(2k) == (b^2)^k (mod m)
Similarly the rab_mil thing is programmed in a very non-scheme fashion. Here's an alternative implementation. Note that there is no 'breaking' of the loops and no call/cc; instead the breaking out is implemented as a tail-recursive call which really corresponds to 'goto' in Scheme:
(define (rab_mil n k)
;; calculate the number 2 appears as factor of 'n'
(define (twos-powers n)
(if (= (remainder n 2) 0)
(+ 1 (twos-powers (/ n 2)))
0))
;; factor n to 2^s * d where d is odd:
(let* ((s (twos-powers n 0))
(d (/ n (expt 2 s))))
;; outer loop
(define (loop k)
(define (next) (loop (- k 1)))
(if (= k 0) 'probably-prime
(let* ((a (+ 2 (random (- n 2))))
(x (expmod a d n)))
(if (or (= x 1) (= x (- n 1)))
(next)
(inner x next))))))
;; inner loop
(define (inner x next)
(define (i r x)
(if (= r s) (next)
(let ((x (expmod x 2 n)))
(case ((= x 1) 'composite)
((= x (- n 1)) (next))
(else (i (+ 1 r) x))))
(i 1 x))
;; run the algorithm
(loop k)))

Resources