I have been trying to think how to implement an algorithm to compute the winding number of a polygon with respect to a point. Currently the implementation is as follows: (note updated so code works)
(defn winding-num
"Return winding number of polygon
see Alciatore "
[poly point]
; translate poly such that point is at origin
(let [translated-poly (map #(vec-f - % point) poly)]
; w is wind-num
(loop [vertices translated-poly w 0]
(cond
(= (count vertices) 1)
w
:else
(let [x1 (first (first vertices))
x2 (first (second vertices))
y1 (second (first vertices))
y2 (second (second vertices))]
(cond
(and (< (* y1 y2) 0)
(> (+ x1 (/ (* y1 (- x2 x1))
(- y1 y2)))
0))
(if (< y1 0)
(recur (rest vertices) (inc w))
(recur (rest vertices) (dec w)))
(and (zero? y1)
(> x1 0))
(if (> y2 0)
(recur (rest vertices) (+ w 0.5))
(recur (rest vertices) (- w 0.5)))
(and (zero? y2)
(> x2 0))
(if (< y1 0)
(recur (rest vertices) (+ w 0.5))
(recur (rest vertices) (- w 0.5)))
:else
(recur (rest vertices) w)))))))
My problems with this are
People say it's preferable when possible to use looping constructs which operate at a higher level than explicit recursion; for instance map, for, reduce, etc.
The rest function converts the vector into a list
I could think of an implementation using for and indices, but I also hear it is preferable to not use indices.
Is there an idiomatic way for dealing with vector algorithms which in each iteration need access to consecutive values?
In general if you want to access consecutive values of a sequence, two at a time, you can use the partition function. Partition allows you to specify a group size as well as a step size:
user> (partition 2 1 (range 10))
((0 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 7) (7 8) (8 9))
It really depends on the shape of your algorithm. Generally speaking higher-level constructs are more understandable than explicit recursion, but sometimes the shape of the problem makes this less clear.
Other things to note:
rest returns a sequence, not a list. This shouldn't matter here.
You should make use of destructuring. For example:
(let [x1 (first (first vertices))
x2 (first (second vertices))
y1 (second (first vertices))
y2 (second (second vertices))
This can be replaced by:
(let [[x1 y1] [x2 y2]] vertices] ... )
However this is not a very difficult algorithm to implement with reduce:
(defn inc-dec
"Convenience function for incrementing and decrementing"
([condition i] (if condition (inc i) (dec i)))
([condition i amount] (if condition (+ i amount) (- i amount))))
(defn winding-num
[poly point]
(let [translated-poly (map #(map - % point) poly)
winding-reducer
(fn winding-reducer [w [[x1 y1] [x2 y2]]]
(cond
(and (< (* y1 y2) 0)
; r
(> (+ x1 (/ (* y1 (- x2 x1))
(- y1 y2)))
0))
(inc-dec (< y1 0) w)
(and (zero? y1) (> x1 0))
(inc-dec (> y2 0) w 0.5)
(and (zero? y2) (> x2 0))
(inc-dec (< y1 0) w 0.5)
:else w))
]
(reduce winding-reducer 0 (partition 2 1 translated-poly))))
The following code is using (map func seq (rest seq)) to handle the pair of points used by the algorithm. It also fixes two problems with the original implementation:
It works whether or not the polygon is specified by repeating the first point as the last, i.e. giving the same result for both
[[1 1][-1 1][-1 -1][1 -1]] and
[[1 1][-1 1][-1 -1][1 -1][1 1]]
It also works for polygons that have successive points on the positive x-axis, whereas the original (and the refered pseudo code) will substract 1/2for each line segment along the x-axis.
(defn translate [vec point]
(map (fn [p] (map - p point)) vec))
(defn sign [x]
(cond (or (not (number? x)) (zero? x)) 0
(pos? x) 1
:else -1))
(defn winding-number [polygon point]
(let [polygon (translate (conj polygon (first polygon)) point)]
(reduce +
(map (fn [[x1 y1][x2 y2]]
(cond (and (neg? (* y1 y2))
(pos? (- x2 (* y2 (/ (- x2 x1) (- y2 y1))))))
(sign y2)
(and (zero? y1) (pos? x1))
(sign y2)
(and (zero? y2) (pos? x2))
(sign y1)
:else 0))
polygon (rest polygon)))))
Related
I am trying to create Pascal's Triangle using recursion. My code is:
(define (pascal n)
(cond
( (= n 1)
list '(1))
(else (append (list (pascal (- n 1))) (list(add '1 (coresublist (last (pascal (- n 1))))))
)))) ;appends the list from pascal n-1 to the new generated list
(define (add s lst) ;adds 1 to the beginning and end of the list
(append (list s) lst (list s))
)
(define (coresublist lst) ;adds the subsequent numbers, takes in n-1 list
(cond ((= (length lst) 1) empty)
(else
(cons (+ (first lst) (second lst)) (coresublist (cdr lst)))
)))
When I try to run it with:
(display(pascal 3))
I am getting an error that says:
length: contract violation
expected: list?
given: 1
I am looking for someone to help me fix this code (not write me entirely new code that does Pascal's Triangle). Thanks in advance! The output for pascal 3 should be:
(1) (1 1) (1 2 1)
We should start with the recursive definition for a value inside Pascals' triangle, which is usually expressed in terms of two parameters (row and column):
(define (pascal x y)
(if (or (zero? y) (= x y))
1
(+ (pascal (sub1 x) y)
(pascal (sub1 x) (sub1 y)))))
There are more efficient ways to implement it (see Wikipedia), but it will work fine for small values. After that, we just have to build the sublists. In Racket, this is straightforward using iterations, but feel free to implement it with explicit recursion if you wish:
(define (pascal-triangle n)
(for/list ([x (in-range 0 n)])
(for/list ([y (in-range 0 (add1 x))])
(pascal x y))))
It'll work as expected:
(pascal-triangle 3)
=> '((1) (1 1) (1 2 1))
I would like to do something similar to matplotlib.pyplot.matshow with racket. I understand this is a trivial question and maybe I'm just being stupid, but I was unsuccessful after reading the Racket plotting documentation.
An example matrix that would be translated into the image of a circle:
#lang typed/racket
(require math/array)
(require plot)
(: sq (-> Integer Integer))
(define (sq [v : Integer])
(* v v))
(: make-2d-matrix (-> Integer Integer (Array Boolean)))
(define (make-2d-matrix [s : Integer] [r : Integer])
(let ([center : Integer (exact-round (/ s 2))])
(let ([a (indexes-array ((inst vector Integer) s s))])
(let ([b (inline-array-map (λ ([i : (Vectorof Index)])
(+
(sq (- (vector-ref i 0) center))
(sq (- (vector-ref i 1) center))))
a)])
(array<= b (array (sq r)))
))))
(array-map (λ ([i : Boolean]) (if (eq? i #f) 0 1)) (make-2d-matrix 20 6))
Can someone give me a hint?
Totally not a dumb question. This is one of those areas where it's hard to compete with an army of python library programmers. Here's how I'd do it in Racket:
#lang racket
(require 2htdp/image
math/array)
;; a 10x10 array
(define a
(build-array #(10 10)
(λ (e)
(match e
[(vector x y)
(cond [(= x y) x]
[else 0])]))))
;; map a value to a color
(define (cmap v)
(color (floor (* 255 (/ v 10)))
0
(floor (* 255 (- 1 (/ v 10))))))
(apply
above
(for/list ([y (in-range 10)])
(apply
beside
(for/list ([x (in-range 10)])
(rectangle 10 10 'solid (cmap (array-ref a (vector x y))))))))
Depending on you situation, you might be interested in flomaps:
http://docs.racket-lang.org/images/flomap_title.html?q=flbitmap
I'm not sure exactly what you want to plot. The plot library is designed around plotting functions, but I don't know what function you want to express.
Here are two ways of plotting a matrix:
(plot (points (cast (array->vector* m) (Vectorof (Vectorof Real)))
(plot3d (points3d (cast (array->vector* m) (Vectorof (Vectorof Real)))
The cast is needed because the type of array->vector* is not specific enough.
I was tasked to write a recursive euclidean distance. I have been googling around but could not find any sample. I understand the function of euclidean distance and has no problem writing it in an iterative manner as shown below. Is there anyone who could advise me on how I should start for the recursive function? The requirement is the same as the iterative version. Thanks.
(defun euclidean-distance-it (p q)
(cond
((or (null p) (null q)) nil) ;return nil if either list is null
((or (atom p) (atom q)) nil) ;return nil if either list is an atom
((or (null (cdr p)) (null (cdr q))) nil);return nil if either list contains less than two inputs
((or (not (null (car(cdr(cdr p))))) (not (null (car(cdr(cdr q)))))) nil) ;return nil if either list contains more than two inputs
((or (or (not (numberp (car p))) (not (numberp (cadr p)))) (or (not (numberp (car q))) (not (numberp (cadr q))))) nil);return nil if any of the four entires aren't numbers
(T (sqrt (+ (expt (- (car p) (car q)) 2)
(expt (- (cadr p) (cadr q)) 2)))))) ;Calculate the euclidean distance
Looking at this Haskell thread, I think your task is more likely to compute the distance of n-dimensional vectors, i.e. sqrt((x1-y1)^2 + ... + (xn-yn)^2).
In your example there is no iteration, you just access elements inside two lists. In other words: you assume that P and Q contains 2 elements and I think the question is to generalize this to N elements.
Moreover, you are doing many useless checks in order to return nil instead of letting errors be signaled. For example, if the lists do not contain numbers, you should probably not return nil.
I would rewrite your version like this:
(defun euclidean-distance-it (p q)
(destructuring-bind (x1 x2) p
(destructuring-bind (y1 y2) q
(sqrt (+ (expt (- x1 y1) 2)
(expt (- x2 y2) 2))))))
With a recursive version, I consider that p and q are two mathematical vectors, so that p contains different coordinates (p1, ..., pn), which differs from your implementation where p contains all x's and q all y's.
So, you have to compute (pi - qi)^2 for each for pair (pi, qi) of elements taken in parallel from p and q, sum the intermediate values and take the square root. With high-order functions, you don't even need to use recursion.
I won't spoil you the recursive answer, but here is a higher-order function version:
(defun distance (p q)
(sqrt
(reduce #'+
(map 'list
(lambda (px qx) (expt (- px qx) 2))
p q))))
And another one with loop:
(defun distance (p q)
(sqrt (loop for px in p
for qx in q
sum (expt (- px qx) 2))))
The only time recursive algorithm for this would be sensible if the input are two vectors (represented by lists) of any dimension, not only 2 or 3. In this case this will compute the square of the distance:
(defun sq-euclid-distance (p q)
(cond ((or (null p) (null q)) 0)
(t (+ (expt (- (car p) (car q)) 2)
(sq-euclid-distance (cdr p) (cdr q))))))
To get SQRT out of it you would need to make it into a auxiliary helper and make a driver computing the square root.
(defun euclid-distance (p q) (sqrt sq-euclid-distance p q))
PS. I am not checking if p and q are atoms, but they can be treated as 1-dimensional vectors. Returning NIL from the function that is expected to provide a numerical value is not a great idea.
I wanted to tell sbcl that the following function will only be called with fixnum values for which the result fits in a fixnum:
(defun layer (x y z n)
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n))))
My first attempt was to do
(defun layer (x y z n)
(declare (fixnum x y z n))
(the fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n))))
But that return type declaration doesn't promise that all intermediate results will also be fixnums, as I found out by looking at the wonderfully useful compilation notes sbcl produced. So then I did this:
(defmacro fixnum+ (&rest args)
(reduce
(lambda (x y) `(the fixnum (+ ,x ,y)))
args))
(defmacro fixnum* (&rest args)
(reduce
(lambda (x y) `(the fixnum (* ,x ,y)))
args))
(defun layer (x y z n)
(declare (fixnum x y z n))
(fixnum+ (fixnum* 2 (fixnum+ (fixnum* x y) (fixnum* y z) (fixnum* x z)))
(fixnum* 4 (fixnum+ x y z n -2) (the fixnum (1- n)))))
And that worked just fine. My question is: is there an easier, more idiomatic way to do this?
For example, maybe I can redeclare the types of +, -, *, 1- to promise fixnum results? (I know that's a bad idea in general, but I might want to do it in certain programs.) CHICKEN scheme has (declare (fixnum-arithmetic)) that does what I want: it (unsafely) assumes that the results of all arithmetic operations on fixnums are fixnums.
You can declare types for functions using FTYPE.
Example:
(defun foo (a b)
(declare (ftype (function (&rest fixnum) fixnum) + * 1-)
(type fixnum a b)
(inline + * 1-)
(optimize (speed 3) (safety 0) (debug 0) (space 0)))
(+ a (* a (1- b))))
Does that make a difference?
In his book ANSI Common Lisp, Paul Graham shows the macro with-type, that wraps an expression and all its sub-expressions inthe forms, also ensuring that operators given more than two arguments are properly handled.
E.g. (with-type fixnum (+ 1 2 3)) will expand to the form
(the fixnum (+ (the fixnum (+ (the fixnum 1) (the fixnum 2)))
(the fixnum 3))
The code for the macro with helper functions is
(defmacro with-type (type expr)
`(the ,type ,(if (atom expr)
expr
(expand-call type (binarize expr)))))
(defun expand-call (type expr)
`(,(car expr) ,#(mapcar #'(lambda (a)
`(with-type ,type ,a))
(cdr expr))))
(defun binarize (expr)
(if (and (nthcdr 3 expr)
(member (car expr) '(+ - * /)))
(destructuring-bind (op a1 a2 . rest) expr
(binarize `(,op (,op ,a1 ,a2) ,#rest)))
expr))
A link to the code from the book in found at http://www.paulgraham.com/acl.html
A comment in the code states that "This code is copyright 1995 by Paul Graham, but anyone who wants
to use it is free to do so."
Try this:
(defun layer (x y z n)
(declare (optimize speed) (fixnum x y z n))
(logand most-positive-fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
See SBCL User Manual, Sec 6.3 Modular arithmetic.
Edit:
As mentioned in the comments, SBCL-1.1.9 (or later) is required for this to work. Also, it's possible to shave another ~40% time off by inlining the subroutines:
;;; From: https://gist.github.com/oantolin/6073417
(declaim (optimize (speed 3) (safety 0)))
(defmacro with-type (type expr)
(if (atom expr)
expr
(let ((op (car expr)))
(reduce
(lambda (x y)
`(the ,type
(,op ,#(if x (list x) '())
(with-type ,type ,y))))
(cdr expr)
:initial-value nil))))
(defun layer (x y z n)
(declare (fixnum x y z n))
(with-type fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
(defun cubes (n)
(declare (fixnum n))
(let ((count (make-array (+ n 1) :element-type 'fixnum)))
(loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
(loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
(loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
(loop for k of-type fixnum from 1 while (<= (layer x y z k) n) do
(incf (elt count (layer x y z k)))))))
count))
(defun first-time (x)
(declare (fixnum x))
(loop for n of-type fixnum = 1000 then (* 2 n)
for k = (position x (cubes n))
until k
finally (return k)))
;;; With modarith and inlining
(defun first-time/inline (x)
(declare (fixnum x))
(labels
((layer (x y z n)
(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
(cubes (n)
(let ((count (make-array (+ n 1) :element-type 'fixnum)))
(loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
(loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
(loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
(loop for k of-type fixnum from 1 while (<= (layer x y z k) n)
do (incf (elt count (layer x y z k)))))))
count)))
(declare (inline layer cubes))
(loop for n of-type fixnum = 1000 then (* 2 n)
thereis (position x (cubes n)))))
#+(or)
(progn
(time (print (first-time 1000)))
(time (print (first-time/inline 1000))))
;; 18522
;; Evaluation took:
;; 0.448 seconds of real time
;; 0.448028 seconds of total run time (0.448028 user, 0.000000 system)
;; 100.00% CPU
;; 1,339,234,815 processor cycles
;; 401,840 bytes consed
;;
;;
;; 18522
;; Evaluation took:
;; 0.259 seconds of real time
;; 0.260016 seconds of total run time (0.260016 user, 0.000000 system)
;; 100.39% CPU
;; 776,585,475 processor cycles
;; 381,024 bytes consed
Declaring the layer function inline results in a much faster speed even when block compilation is on.
On my Apple Air M1 with layer inlined and block compilation on it runs in 0.06 second under the Arm64 version of SBCL 2.1.2.
CL-USER> (time (first-time 1000))
Evaluation took:
0.060 seconds of real time
0.060558 seconds of total run time (0.060121 user, 0.000437 system)
101.67% CPU
303,456 bytes consed
I've just remembered that declaring the count array in cube should help as well.
(declare (type (simple-array fixnum (*)) count))
Without inlining the layer function it is around 0.2 second.
CL-USER> (time (first-time 1000))
Evaluation took:
0.201 seconds of real time
0.201049 seconds of total run time (0.200497 user, 0.000552 system)
100.00% CPU
251,488 bytes consed
Or converting the layer function to a macro makes it even faster.
(defmacro layer (x y z n)
(declare (fixnum x y z n))
`(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
(+ (* 2 (+ (* ,x ,y) (* ,y ,z) (* ,x ,z)))
(* 4 (+ ,x ,y ,z ,n -2) (1- ,n)))))
CL-USER> (time (first-time 1000))
Evaluation took:
0.047 seconds of real time
0.047032 seconds of total run time (0.046854 user, 0.000178 system)
100.00% CPU
312,576 bytes consed
Benchmarked with trivial-benchmark on average it runs just bellow 0.04 second:
CL-USER> (benchmark:with-timing (100) (first-time 1000))
- SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION
REAL-TIME 100 3.985173 0.039528 0.06012 0.039595 0.039852 0.002046
RUN-TIME 100 3.985848 0.039534 0.06014 0.039605 0.039858 0.002048
USER-RUN-TIME 100 3.975407 0.039466 0.059829 0.039519 0.039754 0.002026
SYSTEM-RUN-TIME 100 0.010469 0.00005 0.000305 0.000088 0.000105 0.00005
PAGE-FAULTS 100 0 0 0 0 0 0.0
GC-RUN-TIME 100 0 0 0 0 0 0.0
BYTES-CONSED 100 50200736 273056 504320 504320 502007.38 23010.477
EVAL-CALLS 100 0 0 0 0 0 0.0
I'm trying to learn some functional programming and am doing project euler problems in scheme (racket) to get me started. I'm currently on problem 15 and I think I have a correct function for computing the number of paths in the lattice. Problem is that for large number of gridSize the function takes very long time to run.
(define uniqueTraverse
(lambda (x y gridSize)
(cond
((and (eq? x gridSize) (eq? y gridSize)) 1)
((eq? x gridSize) (uniqueTraverse x (+ y 1) gridSize))
((eq? y gridSize) (uniqueTraverse (+ x 1) y gridSize))
(else (+ (uniqueTraverse (+ x 1) y gridSize)
(uniqueTraverse x (+ y 1) gridSize))))))
I'm trying to figure out how to make this function tail call recursive but I don't know how to do it. I need some help getting started on how to think about optimizing functions like this using tail call optimization.
The problem is that you recompute the same results over and over again.
To solve this, you don't need tail calls - you need to remember old
results and return them without recomputing them. This technique is called memoization.
This is one solution:
#lang racket
(define old-results (make-hash))
(define uniqueTraverse
(lambda (x y gridSize)
(define old-result (hash-ref old-results (list x y) 'unknown))
(cond
; if the result is unknown, compute and remember it
[(eq? old-result 'unknown)
(define new-result
(cond
((and (eq? x gridSize) (eq? y gridSize)) 1)
((eq? x gridSize) (uniqueTraverse x (+ y 1) gridSize))
((eq? y gridSize) (uniqueTraverse (+ x 1) y gridSize))
(else (+ (uniqueTraverse (+ x 1) y gridSize)
(uniqueTraverse x (+ y 1) gridSize)))))
(hash-set! old-results (list x y) new-result)
new-result]
; otherwise just return the old result
[else old-result])))
(uniqueTraverse 0 0 2)
Memoization is one way, another is to use a different data representation.
I used the grid represented as a matrix, or vector of vectors.
Then set the value of the top row to 1 (as there is only on path on the top edge.
After that the next row ther first of the row is one, the second is the value of the entry in the column one above, plus the entry of or value before it in the row,
Recurse for each of the points in the row, and then for each row.
The answer then is the last point in the last row when you are done recursing.
For a 3x3 grid
1 1 1
1 2 3
1 3 6
6
Where the keys are very close together, (continuous, or nearly so) a vector representation is going to be more performant than a hash.
(define (make-lattice-point-square n)
(let ((lps (make-vector (+ n 1))))
(let loop ((i 0))
(if (> i n)
lps
(begin
(vector-set! lps i (make-vector (+ n 1)))
(loop (++ i)))))))
(define (lattice-ref lat x y)
;; where x is row, y is column thought it's not really important
(vector-ref (vector-ref lat y) x))
(define (lattice-set! lat x y value)
(vector-set! (vector-ref lat y) x value))
;; paths through a point are equal the the paths through the above point,
;; plus the paths through the left, those along the top and left edges
;; only have one possible path through them
(define (ways-exit-lattice n)
(let ((lps (make-lattice-point-square n)))
(letrec
((helper
(lambda (x y)
(if (or (= x 0) (= y 0))
(lattice-set! lps x y 1)
(lattice-set! lps x y
(+ (lattice-ref lps (- x 1) y)
(lattice-ref lps x (- y 1)))))))
(lattice-walker
(lambda (x y)
(cond ((and (= x n) (= y n))
(begin (helper x y) (lattice-ref lps x y)))
((= y n)
(begin
(helper x y)
(lattice-walker (++ x) 0)))
(else
(begin
(helper x y)
(lattice-walker x (++ y))))))))
(lattice-walker 0 0))))
notice all the calls to latice-walker are tail calls.
using RSR5 compliant scheme