I'm still pretty new to proper Lisp and I'm trying to build a simple, yet at least a bit efficient insertion sort - I would like to switch elements in place, but still have an ability to append to my container afterwards. I took my old C++ implementation:
template<typename Iter>
void insertionSort(Iter begin, Iter end){
for (auto i = begin; i != end; ++i){
for (auto j = i; j != begin && *(std::prev(j)) > *(j); j--){
std::iter_swap(j, std::prev(j));
}
}
}
And created the following code (taking into account that aref and rotatef have fair complexity), but it does not seem to take any effect on the input (UPD: now it simply works improperly), what might be wrong with my solution? I'm returning for testing purposes, should I create a macro in order to avoid pass-by-value?
(defparameter testa (make-array 4 :initial-contents '(2 3 1 5)))
(defun insertion-sort (vect)
(loop for i from 0 to (1- (length vect)) do
(loop for j from i downto 0
until (or (= (1- j) -1) (> (aref vect (1- j)) (aref vect j)))
do (rotatef (aref vect i) (aref vect (1- j))))
)
vect
)
(format t "~a~%" (insertion-sort testa))
UPD: updated the code based on the comments from #jkiiski and #RainerJoswig, the output is still wrong.
In your program there are several problems.
First, the sort does not work since the line:
do (rotatef (aref vect i) (aref vect (1- j))))
should be:
do (rotatef (aref vect j) (aref vect (1- j))))
that is, you have written the variable i instead of j
If you make this correction, you will find that the order is decreasing (I assume that you want an increasing order). This depends on the use of until instead of while.
Finally, there is redundant code. A more simple and efficient version is the following:
(defparameter testa (make-array 4 :initial-contents '(2 3 1 5)))
(defun insertion-sort (vect)
(loop for i from 1 below (length vect)
do (loop for j from i above 0
while (> (aref vect (1- j)) (aref vect j))
do (rotatef (aref vect j) (aref vect (1- j)))))
vect)
(format t "~a~%" (insertion-sort testa))
This parallel the pseudo-code in the wikipedia page of Insertion sort.
If you want to parameterize the sorting predicate, as well as add an optional keyword-based “key” parameter to the function, here is a possible solution:
(defun insertion-sort (vect predicate &key (key #'identity))
(loop for i from 1 below (length vect)
do (loop for j from i above 0
while (funcall predicate
(funcall key (aref vect (1- j)))
(funcall key (aref vect j)))
do (rotatef (aref vect j) (aref vect (1- j)))))
vect)
CL-USER> (insertion-sort testa #'>)
#(1 2 3 5)
CL-USER> (insertion-sort testa #'<)
#(5 3 2 1)
CL-USER> (defparameter testa (make-array 4 :initial-contents '((c 3) (d 2) (b 1) (a 4))))
TESTA
CL-USER> (insertion-sort testa #'string> :key #'car)
#((A 4) (B 1) (C 3) (D 2))
Related
This is a problem I come up against all the time. I have a function that
does something useful, but I want a version that does something slightly
different as well.
For example, a substring search that finds all of the
positions where some substring occurs in another, longer piece of text.
Then I discover a use case that only requires finding the first instance
of the substring, or the last, or the n'th. Is there an idiomatic way to
factor out the different behaviors from the larger body of common code?
For example, here are two substring search functions. One returns the
first match. The other returns all matches. (Please ignore the fact that
this is a poor way to do a substring search.)
;; Return the index of the first matching instance of `pattern` in
;; `s`. Returns #f if there is no match.
(define (naive-string-find-first pattern s)
(let* ((p-len (string-length pattern))
(limit (- (string-length s) p-len)))
(let outer ((i 0))
(if (<= i limit)
(let inner ((j i)
(k 0))
(if (< k p-len)
(if (char=? (string-ref s j) (string-ref pattern k))
(inner (+ j 1) (+ k 1))
(outer (+ i 1)))
i))
#f))))
;; Return a list of all positions in `s` where `pattern` occurs.
;; Returns '() if there is no match.
(define (naive-string-find-all pattern s)
(let* ((p-len (string-length pattern))
(limit (- (string-length s) p-len)))
(let outer ((i 0))
(if (<= i limit)
(let inner ((j i)
(k 0))
(if (< k p-len)
(if (char=? (string-ref s j) (string-ref pattern k))
(inner (+ j 1) (+ k 1))
(outer (+ i 1)))
(cons i (outer (+ i 1)))))
'()))))
As you can see, they are almost identical, differing only in the last
two lines. Specifically, one of those lines handles proceeding from a match.
The other handles proceeding from a failure to match anything.
What I would like to be able to do is something like:
(define (naive-string-find-common pattern s match-func fail-func)
(let* ((p-len (string-length pattern))
(limit (- (string-length s) p-len)))
(let outer ((i 0))
(if (<= i limit)
(let inner ((j i)
(k 0))
(if (< k p-len)
(if (char=? (string-ref s j) (string-ref pattern k))
(inner (+ j 1) (+ k 1))
(outer (+ i 1)))
(match-func i)))
(fail-func i)))))
(define (naive-string-find-first-common pattern s)
(let ((match-f (lambda (x) x))
(fail-f (lambda (x) #f)))
(naive-string-find-common pattern s match-f fail-f)))
(define (naive-string-find-all-common pattern s)
(let ((match-f (lambda (x) (cons x (outer (+ x 1))))) ;; <-- Fails, of course.
(fail-f (lambda (x) #f)))
(naive-string-find-common pattern s match-f fail-f)))
Handling of the "find-first" behavior works. The "find-all" version
fails because the specialization procedure has no knowledge of the
named let outer.
Is there an idiomatic way to factor out the needed functionality in
cases like this?
As #soegaard says, wrapper functions that add a "flag" argument are idiomatic and clear.
The "What I would like to do" code could be repaired, for example (in Racket to use check-expect:
#lang r6rs
(import (rnrs) (test-engine racket-tests))
(define (naive-string-find-common pattern s match-func fail-func)
(let* ((p-len (string-length pattern))
(limit (- (string-length s) p-len)))
(let outer ((i 0))
(if (<= i limit)
(let inner ((j i)
(k 0))
(if (< k p-len)
(if (char=? (string-ref s j) (string-ref pattern k))
(inner (+ j 1) (+ k 1))
(outer (+ i 1)))
(match-func i (lambda () (outer (+ i 1))) )))
(fail-func i)))))
(define (naive-string-find-first-common pattern s)
(let ((match-f (lambda (x k) x))
(fail-f (lambda (x) #f)))
(naive-string-find-common pattern s match-f fail-f)))
(define (naive-string-find-all-common pattern s)
(let ((match-f (lambda (x k) (cons x (k))))
(fail-f (lambda (x) '())))
(naive-string-find-common pattern s match-f fail-f)))
(check-expect (naive-string-find-first-common "ab" "abab") 0 )
(check-expect (naive-string-find-first-common "ab" "a-b-") #f )
(check-expect (naive-string-find-all-common "ab" "abab") '(0 2) )
(check-expect (naive-string-find-all-common "ab" "a-b-") '() )
(test)
Is there an idiomatic way to factor out the needed functionality in cases like this?
The way you have done is idiomatic.
If two functions f and g do almost the same work, then make a funktion h that can do both. Make h take an extra argument, that indicates whether it should behave as f or g (here a flag that indicates whether to continue after the first needle is found). Finally define "wrappers" f and g that simply calls h with the appropriate flag(s).
I have the following solution:
(defn count-swaps [a]
(letfn [(swap [a i j] ;; looked up letfn online
(assoc a i (nth a j) j (nth a i)))]
(loop [a a num-swaps 0 i 0]
(if (< i (count a))
(let [int-loop (loop [a' a j 0 num-swaps' 0]
(if (< j (dec (count a)))
(if (> (nth a j) (nth a (inc j)))
(recur (swap a' j (inc j)) (inc j) (inc num-swaps'))
(recur a' (inc j) num-swaps'))
[a' num-swaps']))]
(recur (nth int-loop 0) (+ num-swaps (nth int-loop 1)) (inc i)))
[num-swaps (nth a 0) (nth a (dec (count a)))]))))
(let [result (count-swaps [4 2 3 1])]
(prn (str "Array is sorted in " (nth result 0) " swaps.") )
(prn (str "First Element: " (nth result 1)) )
(prn (str "Last Element: " (nth result 2)))
)
For this problem:
https://www.hackerrank.com/challenges/ctci-bubble-sort/problem?h_l=interview&playlist_slugs%5B%5D=interview-preparation-kit&playlist_slugs%5B%5D=sorting
However, upon running submitting the problem, none of the tests pass. I don't know why.
after testing this for about an hour or so, I realized where you're mistaken. Namely, using prn instead of print prints out the quote characters alongside the actual text. This was a surprise to me, since I always thought that these two are interchangeable. If you change your prns to printlns, you should be okay.
The final code that I created which passed all of the tests:
;
; Complete the 'countSwaps' function below.
;
; The function accepts INTEGER_ARRAY a as parameter.
;
(defn count-swaps [a]
(letfn [(swap [a i j] ;; looked up letfn online
(assoc a i (nth a j) j (nth a i)))]
(let [result (loop [a a num-swaps 0 i 0]
(if (< i (count a))
(let [int-loop (loop [a' a j 0 num-swaps' 0]
(if (< j (dec (count a)))
(if (> (nth a j) (nth a (inc j)))
(recur (swap a' j (inc j)) (inc j) (inc num-swaps'))
(recur a' (inc j) num-swaps'))
[a' num-swaps']))]
(recur (nth int-loop 0) (+ num-swaps (nth int-loop 1)) (inc i)))
[num-swaps (nth a 0) (nth a (dec (count a)))]))]
(println (str "Array is sorted in " (nth result 0) " swaps.") )
(println (str "First Element: " (nth result 1)))
(println (str "Last Element: " (nth result 2))))))
(def n (Integer/parseInt (clojure.string/trim (read-line))))
(def a (vec (map #(Integer/parseInt %) (clojure.string/split (clojure.string/trimr (read-line)) #" "))))
(count-swaps a)
Let me know if you need any further clearance on this.
I need to convert strings to 26-ary and then be able to convert them back.
My current code is:
(define (26-ary-word s)
(let ([len (string-length s)])
(let f ([n 0]
[acc (+
(- (char->integer (string-ref s 0)) 97)
1)]) ; adding 1 so that all strings start with 'b'
(if (< n len)
(f (add1 n) (+ (* acc 26) (- (char->integer (string-ref s n)) 97)))
acc))))
(define (word-ary-26 n)
(let f ([n (/ (- n (modulo n 26)) 26)]
[acc (cons (integer->char (+ (modulo n 26) 97)) '())])
(if (> n 0)
(f (/ (- n (modulo n 26)) 26) (cons (integer->char (+ (modulo n 26) 97)) acc))
(list->string (cdr acc))))) ; remove "b" from front of string
I add 1 to acc to start with, and remove the "b" at the end. This is because multiplying "a" - 97 by 26 is still 0.
This is already ugly, but it doesn't even work. "z" is recorded as "701" when it's in the first position (26^2), which is translated back as "az".
I can add another if clause detecting if the first letter is z, but that's really ugly. Is there any way to do this that sidesteps this issue?
(if (and (= n 0) (= acc 26))
(f (add1 n) 51)
(f (add1 n) (+ (* acc 26) (- (char->integer (string-ref s n)) 97))))
This is the ugly edge case handling code I've had to use.
Honestly, I'm not entirely sure what your code is doing, but either way, it's far more complicated than it needs to be. Converting a base-26 string to an integer is quite straightforward just by using some higher-order constructs:
; (char-in #\a #\z) -> (integer-in 0 25)
(define (base-26-char->integer c)
(- (char->integer c) (char->integer #\a)))
; #rx"[a-z]+" -> integer?
(define (base-26-string->integer s)
(let ([digits (map base-26-char->integer (string->list s))])
(for/fold ([sum 0])
([digit (in-list digits)])
(+ (* sum 26) digit))))
By breaking the problem into two functions, one that converts individual characters and one that converts an entire string, we can easily make use of Racket's string->list function to simplify the implementation.
The inverse conversion is actually slightly trickier to make elegant using purely functional constructs, but it becomes extremely trivial with an extra helper function that "explodes" an integer into its digits in any base.
; integer? [integer?] -> (listof integer?)
(define (integer->digits i [base 10])
(reverse
(let loop ([i i])
(if (zero? i) empty
(let-values ([(q r) (quotient/remainder i base)])
(cons r (loop q)))))))
Then the implementation of the string-generating functions becomes obvious.
; (integer-in 0 25) -> (char-in #\a #\z)
(define (integer->base-26-char i)
(integer->char (+ i (char->integer #\a))))
; integer? -> #rx"[a-z]+"
(define (integer->base-26-string i)
(list->string (map integer->base-26-char (integer->digits i 26))))
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.
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)))