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.
Related
I am trying to build a 6-tuple store on top of wiredtiger. The tuples can be described as follow:
(graph, subject, predicate, object, alive, transaction)
Every tuple stored in the database is unique.
Queries are like regular SPARQL queries except that the database store 6 tuples.
Zero of more elements of a tuple can be variable. Here is an example query that allows to retrieve all changes introduces by a particular transaction P4X432:
SELECT ?graph ?subject ?predicate ?object ?alive
WHERE
{
?graph ?subject ?predicate ?object ?alive "P4X432"
}
Considering all possible patterns ends up with considering all combinations of:
(graph, subject, predicate, object, alive, transaction)
That is given by the following function:
def combinations(tab):
out = []
for i in range(1, len(tab) + 1):
out.extend(x for x in itertools.combinations(tab, i))
assert len(out) == 2**len(tab) - 1
return out
Where:
print(len(combinations(('graph', 'subject', 'predicate', 'object', 'alive', 'transaction'))))
Display:
63
That is there 63 combinations of the 6-tuples. I can complete each indices with the missing tuple item, e.g. the following combination:
('graph', 'predicate', 'transaction')
Will be associated with the following index:
('graph', 'predicate', 'transaction', 'subject', 'alive', 'object')
But I know there is a smaller subset of all permutations of the 6-tuple that has the following property:
A set of n-permutations of {1, 2, ..., n} where all combinations of {1, 2, ..., n} are prefix-permutation of at least one element of the set.
Otherwise said, all combinations have a permutation that is prefix of one element of the set.
I found using a brute force algorithm a set of size 25 (inferior to 63) that has that property:
((5 0 1 2 3 4) (4 5 0 1 2 3) (3 4 5 0 1 2) (2 3 4 5 0 1) (1 2 3 4 5 0) (0 1 2 3 4 5) (0 2 1 3 4 5) (0 3 2 1 5 4) (0 4 3 1 5 2) (0 4 2 3 1 5) (2 1 5 3 0 4) (3 2 1 5 0 4) (3 1 4 5 0 2) (3 1 5 4 2 0) (3 0 1 4 2 5) (3 5 2 0 1 4) (4 3 1 0 2 5) (4 2 1 5 3 0) (4 1 0 2 5 3) (4 5 2 1 0 3) (5 4 1 2 3 0) (5 3 0 1 4 2) (5 2 1 3 4 0) (5 1 2 4 0 3) (5 0 2 4 3 1))
Here is the r7rs scheme program I use to compute that solution:
(define-library (indices)
(export indices)
(export permutations)
(export combination)
(export combinations)
(export run)
(import (only (chezscheme) trace-define trace-lambda random trace-let))
(import (scheme base))
(import (scheme list))
(import (scheme comparator))
(import (scheme hash-table))
(import (scheme process-context))
(import (scheme write))
(begin
(define (combination k lst)
(cond
((= k 0) '(()))
((null? lst) '())
(else
(let ((head (car lst))
(tail (cdr lst)))
(append (map (lambda (y) (cons head y)) (combination (- k 1) tail))
(combination k tail))))))
(define (factorial n)
(let loop ((n n)
(out 1))
(if (= n 0)
out
(loop (- n 1) (* n out)))))
(define (%binomial-coefficient n k)
;; https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula
(let loop ((i 1)
(out 1))
(if (= i (+ k 1))
out
(loop (+ i 1) (* out (/ (- (+ n 1) i) i))))))
(define (memo proc)
(let ((m (make-hash-table (make-equal-comparator))))
(lambda args
(if (hash-table-contains? m args)
(hash-table-ref m args)
(let ((v (apply proc args)))
(hash-table-set! m args v)
v)))))
(define binomial-coefficient
(memo
(lambda (n k)
(cond
((= n k) 1)
((= k 0) 1)
(else (%binomial-coefficient n k))))))
;; k-combination ranking and unranking procedures according to
;; https://en.wikipedia.org/wiki/Combinatorial_number_system
(define (ranking lst)
(let loop ((lst (sort < lst)) ;; increasing sequence
(k 1)
(out 0))
(if (null? lst)
out
(loop (cdr lst) (+ k 1) (+ out (binomial-coefficient (car lst) k))))))
(define (%unranking k N)
(let loop ((n (- k 1)))
(if (< N (binomial-coefficient (+ n 1) k))
n
(loop (+ n 1)))))
(define (unranking k N)
(let loop ((k k)
(N N)
(out '()))
(if (= k 0)
out
(let ((m (%unranking k N)))
(loop (- k 1) (- N (binomial-coefficient m k)) (cons m out))))))
(define fresh-random
(let ((memo (make-hash-table (make-eqv-comparator))))
(lambda (n)
(when (= (hash-table-size memo) n)
(error 'oops "no more fresh number" n
))
(let loop ()
(let ((r (random n)))
(if (hash-table-contains? memo r)
(loop)
(begin (hash-table-set! memo r #t) r)))))))
(define (random-k-combination k n)
(unranking k (fresh-random (binomial-coefficient n k))))
(define (combinations lst)
(if (null? lst) '(())
(let* ((head (car lst))
(tail (cdr lst))
(s (combinations tail))
(v (map (lambda (x) (cons head x)) s)))
(append s v))))
;; (define (combinations lst)
;; (append-map (lambda (k) (combination k lst)) (iota (length lst))))
(define (permutations s)
;; http://rosettacode.org/wiki/Permutations#Scheme
(cond
((null? s) '(()))
((null? (cdr s)) (list s))
(else ;; extract each item in list in turn and permutations the rest
(let splice ((l '()) (m (car s)) (r (cdr s)))
(append
(map (lambda (x) (cons m x)) (permutations (append l r)))
(if (null? r) '()
(splice (cons m l) (car r) (cdr r))))))))
(define (shift lst index)
(append (drop lst index) (take lst index)))
(define (rotations lst)
(reverse! (map (lambda (index) (shift lst index)) (iota (length lst)))))
(define (prefix? lst other)
"Return #t if LST is prefix of OTHER"
(let prefix ((lst lst)
(other other))
(if (null? lst)
#t
(if (= (car lst) (car other))
(prefix (cdr lst) (cdr other))
#f))))
(define (indices lst)
(let ((candidates (permutations lst)))
(let loop ((out (rotations lst)) ;; all rotations are solutions
(combinations (combinations lst)))
(if (null? combinations)
(reverse! out)
(let ((permutations (permutations (car combinations))))
(if (any (lambda (s) (any (lambda (p) (prefix? p s)) permutations)) out)
;; there is an existing "solution" for the
;; permutations of COMBINATION move to the next
;; combination
(loop out (cdr combinations))
(loop (cons (find (lambda (c) (if (member c out)
#f
(any (lambda (p) (prefix? p c)) permutations)))
candidates)
out)
(cdr combinations))))))))
(define (permutation-prefix? c o)
(any (lambda (p) (prefix? p o)) (permutations c)))
(define (ok? combinations candidate)
(every (lambda (c) (any (lambda (p) (permutation-prefix? c p)) candidate)) combinations))
(define (run)
(let* ((n (string->number (cadr (command-line))))
(N (iota n))
(solution (indices N))
(min (length solution))
(rotations (rotations N))
(R (length rotations))
;; other stuff
(cx (combinations N))
(px (filter (lambda (x) (not (member x rotations))) (permutations N)))
;; other other stuff
(pn (length px))
(PN (iota pn)))
(display "(length solution) => ") (display (length solution))
(display "\n")
(display "(length rotations) => ") (display R)
(display "\n")
(let try ((x (- (length solution) 1)))
(let ((count (binomial-coefficient pn (- x R))))
(let loop ((index 0)
(cxx (map (lambda (x) (list-ref px x)) (random-k-combination (- x R) pn))))
(when (= (modulo index (expt 10 5)) 0)
(display "n=") (display n) (display " x=") (display x)
(display " ")
(display index) (display "/") (display count) (display "\n"))
(let ((candidate (append rotations cxx)))
(let ((continue? (not (ok? cx candidate))))
(if continue?
(loop (+ index 1)
(map (lambda (x) (list-ref px x)) (random-k-combination (- x R) pn)))
(begin (display "new solution n=") (display n)
(display " length=") (display x)
(display " ") (display candidate)
(display "\n")
(try (- x 1)))))))))))
))
With that list of permutations I can query any pattern.
I am wondering if there is a smaller set and whether there is definitive algorithm to compute that kind of set.
Based on this answer https://math.stackexchange.com/a/3146793/23663
The following program yields a solution that is a minimal solution according to math ™:
import itertools
import math
f = math.factorial
bc = lambda n, k: f(n) // f(k) // f(n-k) if k<n else 0
def pk(*args):
print(*args)
return args[-1]
def stringify(iterable):
return ''.join(str(x) for x in iterable)
def combinations(tab):
out = []
for i in range(1, len(tab) + 1):
out.extend(stringify(x) for x in itertools.combinations(tab, i))
assert len(out) == 2**len(tab) - 1
return out
def ok(solutions, tab):
cx = combinations(tab)
px = [stringify(x) for x in itertools.permutations(tab)]
for combination in cx:
pcx = [''.join(x) for x in itertools.permutations(combination)]
# check for existing solution
for solution in solutions:
if any(solution.startswith(p) for p in pcx):
# yeah, there is an existing solution
break
else:
print('failed with combination={}'.format(combination))
break
else:
return True
return False
def run(n):
tab = list(range(n))
cx = list(itertools.combinations(tab, n//2))
for c in cx:
L = [(i, i in c) for i in tab]
A = []
B = []
while True:
for i in range(len(L) - 1):
if (not L[i][1]) and L[i + 1][1]:
A.append(L[i + 1][0])
B.append(L[i][0])
L.remove((L[i + 1][0], True))
L.remove((L[i][0], False))
break
else:
break
l = [i for (i, _) in L]
yield A + l + B
for i in range(7):
tab = stringify(range(i))
solutions = [stringify(x) for x in run(i)]
assert ok(solutions, tab)
print("n={}, size={}, solutions={}".format(i, len(solutions), solutions))
The above program output is:
n=0, size=1, solutions=['']
n=1, size=1, solutions=['0']
n=2, size=2, solutions=['01', '10']
n=3, size=3, solutions=['012', '120', '201']
n=4, size=6, solutions=['0123', '2031', '3012', '1230', '1302', '2310']
n=5, size=10, solutions=['01234', '20341', '30142', '40123', '12340', '13402', '14203', '23410', '24013', '34021']
n=6, size=20, solutions=['012345', '301452', '401253', '501234', '203451', '240513', '250314', '340521', '350124', '450132', '123450', '142503', '152304', '134502', '135024', '145032', '234510', '235104', '245130', '345210']
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))
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'm in the process of writing a matrix transpose function in lisp. My approach can be seen from the following code:
(defun matrix-T (matrix)
(cond ((null matrix) matrix)
(t (list
(do ((i 0 (+ i 1)))
((> i (length matrix)))
(format t "(mapcar #'(lambda (x)(nth ~A x)) matrix) %" i))))))
As you can see, I'm trying to get the output from the do loop to pass as an
argument for the list function. However, I only get the do loop output returned from matrix-T. Is there anyway I can rectify this?
A dead-simple straight forward way to transpose a matrix:
(defun transpose-matrix (matrix)
(let ((result
(make-array (reverse (array-dimensions matrix))
:element-type (array-element-type matrix))))
(dotimes (i (array-dimension result 0) result)
(dotimes (j (array-dimension result 1))
(setf (aref result i j) (aref matrix j i))))))
(print
(transpose-matrix
#2A((1 2 3)
(4 5 6))))
;; #2A((1 4) (2 5) (3 6))
You need to actually run the MAPCAR and collect its results in a list, not just print or return it as a string.
(defun matrix-T (matrix)
(cond ((null matrix) matrix)
(t (do ((i 0 (1+ i))
(result '())
(cols (length (car matrix))))
((>= i cols) (nreverse result))
(push (mapcar #'(lambda (x) (nth i x)) matrix) result)))))
An elegant way to transpose using mapcar*
(defun transpose-matrix (matrix)
(apply #'mapcar* #'list matrix))
(transpose-matrix '(("1" "a" "e") ("2" "b" "f") ("4" "c" "g") ("5" "d" "h")))
(("1" "2" "4" "5") ("a" "b" "c" "d") ("e" "f" "g" "h"))
It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 10 years ago.
Example input:
((a1 . b) (a1 . c)):
I have one list with two elements, those elements are lists or pairs with two elements. And i want to check if the first element of the first pair/list is equal to the first element of the second pair/list.
output: If so, i want to create a new list with two lists, the first is the list:
while (b < c) -> (a1 . b(even)) (a1 . b+2(even))...
The other list is the same, but with the odd's
How do I implement this in scheme:
INPUT:
((1 . 1) (1 . 7))
OUTPUT:
(((1 . 2) (1 . 4) (1 . 6)) ((1 . 3) (1 . 5) (1 . 7)))
I have one list with two elements. Each element is also a list with two elements, both integers >= 0 and < 8
I have to create this:
input ((a1 . b) (a1 . c))
output: (if (and (= a1 a2) (odd? b))
While < b c
(list (a1 . b+1) (a1 . b+3) (a1 . b+n)...))
(list (a2 . b) (a2 . b+2) (a2 . b+4)...)
I had done this, but i can't find where i'm failing, could you help me?....
;;; Verify if absissa0 = absissa1
(define (game-position input)
(if (= (car (car j)) (cdr (cdr j)))
(col1_col2 j)
(error "Not valid"))))
;;; verify if absissa0 is even
(define (col1_col2 gstart)
(if (even? (cdr (car jstart)))
(list (pos-start jstart))
(list (pos-start (list (cons (car (car jstart)) (- (cdr (car jstart)) 1)) (car (cdr jstart))))))
;;; Loop that creates positions of even's and odd's
(define (pos-start j2)
(while ( < (cdr (car j2)) (- (cdr (cdr j2)) 2))
((cons (car (car j2)) (+ (cdr (car j2)) 2)) (pos-start (list (cons (car (car j2)) (+ (cdr (car j2)) 2)) (car (cdr j2)))))
(odd_2 (list (cons (car (car j2)) (+ (cdr (car j2)) 1)) (car (cdr j2)))))
(define (odd_2 j3)
(while ( < (cdr (car j3)) (- (car (cdr j3)) 2))
((j3) (odd_2 (list (cons (car (car j3)) (+ (cdr (car j3)) 2)) (car (cdr j3)))
(value)))
; position l e a coluna c.
(define (do-pos l c)
(if (and (integer? l) (integer? c) (>= l 0) (>= c 0) (<= l 7) (<= c 7))
(cons l c)
(error "insert a valid number between 0 and 7")))
; returns l
(define (line-pos p)
(car p))
; returns c
(define (column-pos p)
(cdr p))
; Arg is position.
(define (pos? arg)
(and (pair? arg) (integer? (line-pos arg)) (integer? (column-pos arg)) (< (car arg) 8) (>= (car arg) 0) (< (cdr arg) 8) (>= (cdr arg) 0)))
; two positions are equal?
(define (pos=? p1 p2)
(and (= (line-pos p1)(line-pos p2))(= (column-pos p1)(column-pos p2))))
(define (oper* x y)
(* (- x y) (- x y)))
; Distance between p1 e p2.
(define (distance p1 p2)
(sqrt (+ (oper* (line-pos p1) (line-pos p2)) (oper* (column-pos p1) (column-pos p2)))))
; Same directions? if same line and same column
(define (same-direction? p1 p2)
(or (= (line-pos p1) (line-pos p2)) (= (column-pos p1) (column-pos p2))))
; check if to positions are adjacent
(define (adjacent? p1 p2)
(and (same-direccao? p1 p2) (= (distance p1 p2) 1)))
; from a position, returns all adjacents moves
(define (adjacent p) (cond ((and (= (line-pos p) 0) (= (column-pos p) 0)) (list (faz-pos (+ (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (+ (column-pos p) 1))))
((and (= (line-pos p) 7) (= (column-pos p) 7)) (list (do-pos (- (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (- (column-pos p) 1))))
((= (line-pos p) 0) (list (do-pos (+ (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (+ (column-pos p) 1)) (do-pos (line-pos p) (- (column-pos p) 1))))
((= (column-pos p) 0) (list (do-pos (+ (line-pos p) 1) (column-pos p)) (do-pos (- (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (+ (column-pos p) 1))))
((= (line-pos p) 7) (list (do-pos (- (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (+ (column-pos p) 1)) (do-pos (line-pos p) (- (column-pos p) 1))))
((= (column-pos p) 7) (list (do-pos (+ (line-pos p) 1) (column-pos p)) (do-pos (- (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (- (column-pos p) 1))))
(else (list (do-pos (+ (line-pos p) 1) (column-pos p)) (do-pos (- (line-pos p) 1) (column-pos p)) (do-pos (line-pos p) (+ (column-pos p) 1)) (do-pos (line-pos p) (- (column-pos p) 1))))))
; returns a move with p1 and p2
(define (do-game p1 p2)
(if (and (pos? p1) (pos? p2))
(list p1 p2)
(error "Insert two valid positions")))
; returns the beguining of j.
(define (b-do-game j)
(car j))
; returns the end of j.
(define (e-do-hame j)
(car (cdr j)))
; Arg is a do-game?.
(define (do-game? arg)
(and (list? arg) (pos? (b-do-game arg)) (pos? (e-do-game arg))))
; do game is null?.
(define (do-game-null? j)
(pos=? (b-do-game j) (e-do-game j)))
; list with two do-game (pc and pl)
(define (play-pos pc pl)
(if (and (list? pc) (list? pl))
(list pc pl)
(error "Insere two valid moves")))
; returns pc.
(define (cap-pieces pj)
(b-do-game pj))
; returns pj
(define (free_pieces pj)
(e-do-game pj))
(define (neven n)
(if (even? n)
n (+ n 1)))
; create sublists
(define (sublist a mn mx)
(cond ((<= mn mx) (cons (do-pos a mn) (sublist a (+ mn 2) mx)))
(else '())))
(define (sublist2 a mn mx)
(cond ((<= mx (- mn 2)) (cons (do-pos a (- mn 2)) (sublist2 a (- mn 2) mx)))
(else '())))
(define (sublist3 a mn mx)
(cond ((<= mn mx) (cons (do-pos mn a) (sublist3 a (+ mn 2) mx)))
(else '())))
(define (sublist4 a mn mx)
(cond ((<= mx (- mn 2)) (cons (do-pos (- mn 2) a) (sublist4 a (- mn 2) mx)))
(else '())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Returns game-positions
(define (game-positions j)
(if (not (and (do-game? j) (same-direction? (b-do-game j) (e-do-game j)) (even? (distance (b-do-game j) (e-do-game j)))))
(list)
(if (= (line-pos (b-do-game j)) (line-pos (e-do-game j)))
(f_odd_even? j)
(f_odd_even2? j))))
; Check is starts with odd or even.
(define (f_odd_even? j) (if (even? (column-pos (b-do-game j)))
(b_even j)
(b_odd j)))
(define (f_odd_even2? j) (if (even? (line-pos (b-do-jogada j)))
(b-even1 j)
(b_odd1 j)))
; If starts with odd:
(define (b_odd j)
(if (< (column-pos (b-do-game j)) (column-pos (e-do-game j)))
(list (sublist (line-pos (b-do-game j))
(neven (column-pos (b-do-game j)))
(column-pos (e-do-game j)))
(sublist (line-pos (b-do-game j))
(+ 1 (neven (column-pos (b-do-game j))))
(column-pos (e-do-game j))))
(list (sublist2 (line-pos (b-do-game j))
(+ 1 (column-pos (b-do-game j)))
(column-pos (e-do-game j)))
(sublist2 (line-pos (b-do-game j))
(column-pos (b-do-game j))
(- 1 (column-pos (e-do-game j)))))))
(define (b_even j)
(if (< (column-pos (b-do-game j)) (column-pos (e-do-game j)))
(list (sublist (line-pos (b-do-game j))
(+ 2 (neven (column-pos (b-do-game j))))
(column-pos (e-do-game j)))
(sublist (line-pos (b-do-game j))
(+ 1 (neven (column-pos (b-do-game j))))
(column-pos (e-do-game j))))
(list (sublist2 (line-pos (b-do-game j))
(column-pos (b-do-game j))
(column-pos (e-do-game j)))
(sublist2 (line-pos (b-do-game j))
(+ 1 (column-pos (b-do-game j)))
(column-pos (e-do-game j))))))
(define (b_odd1 j)
(if (< (line-pos (b-do-game j)) (column-pos (e-do-game j)))
(list (sublist3 (column-pos (b-do-game j))
(neven (line-pos (b-do-game j)))
(line-pos (e-do-game j)))
(sublist3 (column-pos (b-do-game j))
(+ 1 (neven (line-pos (b-do-game j))))
(line-pos (e-do-game j))))
(list (sublist4 (column-pos (b-do-game j))
(+ 1 (line-pos (b-do-game j)))
(line-pos (e-do-game j)))
(sublist4 (column-pos (b-do-game j))
(line-pos (b-do-game j))
(- 1 (line-pos (e-do-game j)))))))
(define (b_even1 j)
(if (< (line-pos (b-do-game j)) (line-pos (e-do-game j)))
(list (sublist3 (column-pos (b-do-game j))
(+ 2 (neven (line-pos (b-do-game j))))
(line-pos (e-do-game j)))
(sublist3 (column-pos (b-do-game j))
(+ 1 (neven (line-pos (b-do-game j))))
(line-pos (e-do-game j))))
(list (sublist4 (column-pos (b-do-game j))
(line-pos (b-do-game j))
(line-pos (e-do-game j)))
(sublist4 (column-pos (b-do-game j))
(+ 1 (line-pos (b-do-game j)))
(line-pos (e-do-game j))))))
This is the first part of the game I'm making, I was translating the variables from portuguese to english so it could have some error.
Dlm, can you do the same that you did in your code with "while cicles"?
Could you check my code and improve it a litle? I am trying to improve my programming skills, and it's starts from my code, Basicaly I want to get a programming style
Sorry for the previous posting. It was my first post
and I posted as an unregistered user. I obviously
haven't figured out how to format text yet.
I've created an account (user dlm) and I'm making a
second attempt -- here goes.
I've been working on learning Racket/Scheme for a while
now and this site looks like a great place to share and
learn from others.
I'm not 100% sure of the spec on this question and
have my doubts that my code actually solves the problem
at hand but I think it's readable enough to be modified
as needed
Readability is one of the things I've been working on
and would appreciate feedback/suggestions from others.
dlm.
My 2 cents :
(define (process-list? lst)
(let*([pair-0 (list-ref lst 0)]
[pair-1 (list-ref lst 1)])
(and (= (car pair-0) (car pair-1))
(< (cdr pair-0) (cdr pair-1)))))
(define (make-odd/even-sets data)
(let*([x (car (list-ref data 0))]
[y-start (cdr (list-ref data 0))]
[max (cdr (list-ref data 1))])
(define (loop y evens odds)
(if (<= y max)
(loop (add1 y)
(if (even? y) (cons (cons x y) evens) evens)
(if (odd? y) (cons (cons x y) odds) odds))
(list (reverse odds) (reverse evens))))
(loop y-start '() '())))
(define (main data)
(if (process-list? data)
(let*([odd/even (make-odd/even-sets data)])
(printf "~a~n" (list-ref odd/even 0))
(printf "~a~n" (list-ref odd/even 1)))
(printf "Invalid list~n" )))
(main '((1 . 1) (1 . 7)) )
UPDATE:
Hi gn66,
I don't know how much I can actually do in terms of the
game itself but I might be able to give you some
pointers/ideas.
A major thing to look for in improving code is to to
look for repeating code applied to specific situations
and try to think of ways to generalize. At first the
generalized form can seam harder to read when you don't
see what's going on but once you fully understand it
it's actually easier, not only to read but modify.
Looking at your code the 'adjacent' procedure jumps out
as something that could be shortened so I'll use that as
an example. Let's start by first ignoring the boundary
conditions and look for the generial pattern of
operations (example: where you put the logic for
conditional test can have a big effect on the size of the
code).
(define (adjacent p)
(list (do-pos (+ (line-pos p) 1) (column-pos p))
(do-pos (- (line-pos p) 1) (column-pos p))
(do-pos (line-pos p) (+ (column-pos p) 1))
(do-pos (line-pos p) (- (column-pos p) 1))) )
The problem here can be partitioned into 2 different
problems: 1) changing line postions + - 1 and
2) changing row positions + - 1. Both applying
the same operations to different components of the
position. So let's just work with one.
(instead of a while loop lets look at MAP which is
like a "while list not empty" loop)
Using 'map' to apply an operation to data list(s)
is pretty straight forward:
(map (lambda (val) (+ val 5))
'(10 20 30))
If needed you can inclose it inside the scope of a procdure
to maintain state information such as a counter:
(define (test lst)
(let*([i 0])
(map (lambda (val)
(set! i (+ i 1))
(+ val i))
lst)))
(test '(10 20 30))
Or pass in values to use in the operation:
(define (test lst amount)
(map (lambda (val) (+ val amount))
lst))
(test '(10 20 30) 100)
Now turn your thinking inside out and consider that
it's possible to have it map a list of operations to
some data rather than data to the operation.
(define (test val operations-lst)
(map (lambda (operation) (operation val))
operations-lst))
(test 10 (list sub1 add1))
Now we have the tools to start creating a new
'adjacent' procedure:
(define (adjacent p)
(define (up/down p) ;; operations applied to the line componet
(map (lambda (operation)
(cons (operation (line-pos p)) (column-pos p)))
(list add1 sub1)))
(define (left/right p) ;; operations applied to the column componet
(map (lambda (operation)
(cons (line-pos p) (operation (column-pos p))))
(list add1 sub1)))
(append (up/down p) (left/right p))
)
(adjacent (do-pos 1 1))
This works find for positions that aren't on the boundary
but just as the old saying goes "it's sometimes easier to do
something and then apologize for it than it is to first ask
permission". Let's take the same approach and let the errant
situations occur then remove them. The 'filter' command is
just the tool for the job.
The 'filter' command is similiar to the map command in that
it takes a list of values and passes them to a function. The
'map' command returns a new list containing new elements
that correpsond to each element consumed. Filter returns
the original values but only the ones that the (predicate)
function "approves of" (returns true for).
(filter
(lambda (val) (even? val))
'(1 2 3 4 5 6 7 8))
will return the list (2 4 6 8)
So adding this to the new 'adjacent' procedure we get:
(define (adjacent p)
(define (up/down p)
(map (lambda (operation)
(cons (operation (line-pos p)) (column-pos p)))
(list add1 sub1)))
(define (left/right p)
(map (lambda (operation)
(cons (line-pos p) (operation (column-pos p))))
(list add1 sub1)))
(define (select-valid p-lst)
(filter
(lambda (p) (and (>= (line-pos p) 0) (>= (column-pos p) 0)
(<= (line-pos p) 7) (<= (column-pos p) 7)))
p-lst))
(select-valid
(append (up/down p) (left/right p))))
As for the "while cycles" you asked about: you need to
develop the ability to "extract" information like this from
existing examples. You can explore different aspects of
existing code by trying to remove as much code as you can
and still get it to work for what you are interested in
(using print statements to get a window onto what's going
on). This is a great way to learn.
From my first posting cut out the loop that creates the
evens/odds list. When you try to run you find out what is
missing (the dependencies) from the error messages so
just define them as needed:
(define x 1)
(define max 5)
(define (loop y evens odds)
(if (<= y max)
(loop (add1 y)
(if (even? y) (cons (cons x y) evens) evens)
(if (odd? y) (cons (cons x y) odds) odds))
(list (reverse odds) (reverse evens))))
(loop 1 '() '())
Add a print statement to get info on the mechanics of how
it works:
(define x 1)
(define max 5)
(define y-start 1)
(define (loop y evens odds)
(if (<= y max)
(begin
(printf "section 1 : y=~a~n" y)
(loop (add1 y)
(if (even? y) (cons (cons x y) evens) evens)
(if (odd? y) (cons (cons x y) odds) odds)))
(begin
(printf "section 2 : y=~a~n" y)
(list (reverse odds) (reverse evens))
)))
(loop y-start '() '())
Now remove parts you aren't interested in or don't need,
which may take some exploration:
(let*([max 5])
(define (loop y)
(if (<= y max)
(begin
(printf "section 1 : y=~a~n" y)
(loop (add1 y)))
(begin
(printf "section 2 : y=~a~n" y)
'()
)))
(loop 1))
Now you should be able to more easily see the mechanics of a
recursive while loop and use this as a simple template
to apply to other situations.
I hope this helps and I hope it doesn't cross the line
on the "subjective questions" guidelines -- I'm new to
this site and hope to fit in as it looks like a great
resource.
I'm a bit rusty in scheme, I've managed to get this solution to your problem,
it use recursion vs while, but I'm not accustomed to that construct in scheme:
(define data (list (cons 1 1) (cons 1 7)))
(define (neven n) (if (even? n) n (+ n 1)))
(define (sublist a mn mx)
(cond
((<= mn mx ) (cons (cons a mn) (sublist a (+ mn 2) mx)))
(else '())))
(define (game-position input)
(if (= (caar input) (caadr input))
(list (sublist (caar input)
(neven (cdar input))
(cdadr input))
(sublist (caar input)
(+ 1 (neven (cdar input)))
(cdadr input)))
(error "no match")))
(game-position data)
edit: It works in guile and drscheme. Hope it will works in plt-scheme too.
edit: sublist inner working
First the parameters:
a is the car of the pairs contained into the list
mn is the cdr of the first pair
mx is the upper limit of the serie.
the body of the function is quite simple:
if the cdr of the current pair is smaller or equal to the upper limit then return a list
composed by a pair (a . mn) and the list created by a call to sublist with the mn parameter changed to reflect the next possible pair.
if the current pair will have a cdr higher than the upper limit then return null (empty list) in order to close the cons issued by the previous invocation of sublist.
I've been working on learning Racket/Scheme for a while
now and this site looks like a great place to share and
learn from others.
I'm not 100% sure of the spec on this question and
have my doubts that my code actually solves the problem
at hand but I think it's readable enough to be modified
as needed
Readability is one of the things I've been working on
and would appreciate feedback/suggestions from others.
dlm.
My 2 cents :
(define (process-list? lst)
(let*([pair-0 (list-ref lst 0)]
[pair-1 (list-ref lst 1)])
(and (= (car pair-0) (car pair-1))
(< (cdr pair-0) (cdr pair-1)))))
(define (make-odd/even-sets data)
(let*([x (car (list-ref data 0))]
[y-start (cdr (list-ref data 0))]
[max (cdr (list-ref data 1))])
(define (loop y evens odds)
(if (<= y max)
(loop (add1 y)
(if (even? y) (cons (cons x y) evens) evens)
(if (odd? y) (cons (cons x y) odds) odds))
(list (reverse odds) (reverse evens))))
(loop y-start '() '())))
(define (main data)
(if (process-list? data)
(let*([odd/even (make-odd/even-sets data)])
(printf "~a~n" (list-ref odd/even 0))
(printf "~a~n" (list-ref odd/even 1)))
(printf "Invalid list~n" )))
(main '((1 . 1) (1 . 7)) )