## Basic 2D Geometry Routines

From: "andrew cooke" <andrew@...>

Date: Sat, 18 Aug 2007 16:28:41 -0400 (CLT)

I *think* this is fairy efficient, but haven't actually done any profiling
(I know...)

":";exec snow -- "$0" "$@"

(package* napito-base/v1.0.0

(provide:
(define (nap-default-transform)))

(author: "Andrew Cooke <andrew at acooke.org>")
(homepage: "http://www.acooke.org")
(description: "Napito drawing description language - support routines")
(keywords: graphics)

(define (nap-default-transform) '(1 0 0 0 1 0))

(define-syntax dot
(syntax-rules ()
((_ (op1 arg1 ...) (op2 arg2 ...))
(receive (a b c) (op1 arg1 ...)
(receive (x y z) (op2 arg2 ...)
(+ (* a x) (* b y) (* c z)))))))

(define-syntax row1 (syntax-rules () ((_ a b c d e f) (values a b c))))
(define-syntax row2 (syntax-rules () ((_ a b c d e f) (values d e f))))
(define-syntax col1 (syntax-rules () ((_ a b c d e f) (values a d 0))))
(define-syntax col2 (syntax-rules () ((_ a b c d e f) (values b e 0))))
(define-syntax col3 (syntax-rules () ((_ a b c d e f) (values c f 1))))
(define-syntax xyz  (syntax-rules () ((_ x y)         (values x y 1))))

(define-syntax split (syntax-rules () ((_ lst) (values (car lst) (cdr
lst)))))

(define (unpack6 lst)
(values a b c d e f))))))))

(define (unpack2 lst)
(values a b))))

(define (nap-transform-point transform point)
(receive (a b c d e f) (unpack6 transform)
(list (dot (row1 a b c d e f) (xyz x y))
(dot (row2 a b c d e f) (xyz x y))))))

(define (nap-join-transforms before extra)
(receive (p q r s t u) (unpack6 before)
(receive (a b c d e f) (unpack6 extra)
(list (dot (row1 p q r s t u) (col1 a b c d e f))
(dot (row1 p q r s t u) (col2 a b c d e f))
(dot (row1 p q r s t u) (col3 a b c d e f))
(dot (row2 p q r s t u) (col1 a b c d e f))
(dot (row2 p q r s t u) (col2 a b c d e f))
(dot (row2 p q r s t u) (col3 a b c d e f))))))

(test*
(let ((unit '(1 0 0 0 1 0))
(doublex '(2 0 0 0 1 0))
(incx '(1 0 1 0 1 0))
(one '(1 1)))
(expect* (equal? '(1 1) (nap-transform-point unit one)))
(expect* (equal? '(2 1) (nap-transform-point doublex one)))
(expect* (equal? '(2 1) (nap-transform-point incx one)))
(expect* (equal? unit (nap-join-transforms unit unit)))
(expect* (equal? '(4 1)
(nap-transform-point
(nap-join-transforms doublex incx) one)))
(expect* (equal? '(3 1)
(nap-transform-point
(nap-join-transforms incx doublex) one)))))

### More Specific Operations

From: "andrew cooke" <andrew@...>

Date: Sat, 18 Aug 2007 17:00:31 -0400 (CLT)

(define (nap-shift-x d) (list 1 0 d 0 1 0))
(define (nap-shift-y d) (list 1 0 0 0 1 d))
(define (nap-scale f) (list f 0 0 0 f 0))
(define (nap-scale-x f) (list f 0 0 0 1 0))
(define (nap-scale-y f) (list 1 0 0 0 f 0))
(define pi 3.1415926)
(define (nap-rotate-deg d)
(let* ((r (/ (* pi d) 180))
(c (cos r))
(s (sin r)))
(list c (- s) 0 s c 0)))

(test*
(define (almost-equal? ab pq)
(define (close x y) (< (abs (- x y)) 0.01))
(and (close a p) (close b q)))))
(let ((unit '(1 0 0 0 1 0))
(incx2 (nap-shift-x 2))
(incy3 (nap-shift-y 3))
(double (nap-scale 2))
(scalex3 (nap-scale-x 3))
(scaley4 (nap-scale-y 4))
(rot90 (nap-rotate-deg 90))
(one '(1 1)))
(expect* (equal? '(3 1) (nap-transform-point incx2 one)))
(expect* (equal? '(1 4) (nap-transform-point incy3 one)))
(expect* (equal? '(2 2) (nap-transform-point double one)))
(expect* (equal? '(3 1) (nap-transform-point scalex3 one)))
(expect* (equal? '(1 4) (nap-transform-point scaley4 one)))
(expect* (almost-equal? '(0.999 -0.001) '(1 0)))
(expect* (almost-equal? '(-1 1) (nap-transform-point rot90 one)))))

Andrew

### Not Efficient!

From: "andrew cooke" <andrew@...>

Date: Sun, 19 Aug 2007 18:00:57 -0400 (CLT)

The values/receive code is constructing and discarding vectors,
apparently.  need to rewrite...

Andrew

### Significantly Faster

From: "andrew cooke" <andrew@...>

Date: Sun, 19 Aug 2007 21:15:33 -0400 (CLT)

I've removed values/receive by (1) using CPS in the macros that select
particular elements and (2) using vectors, which simplifies unpacking.

":";exec snow -- "$0" "$@"

; this is about 40% faster than napito-base.scm

; qp6 napito: ./napito-vector.scm
; warming up
; 100000 timing
; (time (speed 1 %%n1414))
;     1403 ms real time
;     1316 ms cpu time (1316 user, 0 system)
;     95 collections accounting for 571 ms real time (548 user, 0 system)
;     891208784 bytes allocated
;     no minor faults
;     no major faults

(package* napito-vector/v1.0.0

(provide:
(define nap-default-transform)
(define (nap-transform-handler engine))
(define (nap-join-transforms before extra))
(define (nap-transform-point transform point)))

(author: "Andrew Cooke <andrew at acooke.org>")
(homepage: "http://www.acooke.org")
(description: "Napito drawing description language - support routines")
(keywords: graphics)

(define nap-default-transform '#(1 0 0 0 1 0))

(define (dot a b c) (lambda (p q r) (+ (* a p) (* b q) (* c r))))

(define-syntax row1 (syntax-rules () ((_ a b c d e f fun) (fun a b c))))
(define-syntax row2 (syntax-rules () ((_ a b c d e f fun) (fun d e f))))
(define-syntax col1 (syntax-rules () ((_ a b c d e f fun) (fun a d 0))))
(define-syntax col2 (syntax-rules () ((_ a b c d e f fun) (fun b e 0))))
(define-syntax col3 (syntax-rules () ((_ a b c d e f fun) (fun c f 1))))
(define-syntax xyz  (syntax-rules () ((_ x y fun)         (fun x y 1))))

; this is *much* slower
; (define (row1 a b c d e f fun) (fun a b c))
; (define (row2 a b c d e f fun) (fun d e f))
; (define (col1 a b c d e f fun) (fun a d 0))
; (define (col2 a b c d e f fun) (fun b e 0))
; (define (col3 a b c d e f fun) (fun c f 1))
; (define (xyz  x y fun)         (fun x y 1))

(define (unpack6 vec fun)
(let* ((a (vector-ref vec 0))
(b (vector-ref vec 1))
(c (vector-ref vec 2))
(d (vector-ref vec 3))
(e (vector-ref vec 4))
(f (vector-ref vec 5)))
(fun a b c d e f)))

(define (unpack2 vec fun)
(let* ((a (vector-ref vec 0))
(b (vector-ref vec 1)))
(fun a b)))

(define (nap-transform-point transform point)
(unpack6 transform (lambda (a b c d e f)
(unpack2 point (lambda (x y)
(vector (row1 a b c d e f (xyz x y dot))
(row2 a b c d e f (xyz x y dot))))))))

(define (nap-join-transforms before extra)
(unpack6 before (lambda (p q r s t u)
(unpack6 extra (lambda (a b c d e f)
(vector (row1 p q r s t u (col1 a b c d e f dot))
(row1 p q r s t u (col2 a b c d e f dot))
(row1 p q r s t u (col3 a b c d e f dot))
(row2 p q r s t u (col1 a b c d e f dot))
(row2 p q r s t u (col2 a b c d e f dot))
(row2 p q r s t u (col3 a b c d e f dot))))))))

(test*
(let ((unit '#(1 0 0 0 1 0))
(doublex '#(2 0 0 0 1 0))
(incx '#(1 0 1 0 1 0))
(one '#(1 1)))
(expect* (equal? '#(1 1) (nap-transform-point unit one)))
(expect* (equal? '#(2 1) (nap-transform-point doublex one)))
(expect* (equal? '#(2 1) (nap-transform-point incx one)))
(expect* (equal? unit (nap-join-transforms unit unit)))
(expect* (equal? '#(4 1)
(nap-transform-point
(nap-join-transforms doublex incx) one)))
(expect* (equal? '#(3 1)
(nap-transform-point
(nap-join-transforms incx doublex) one)))))

(define (nap-shift-x d) (list 1 0 d 0 1 0))
(define (nap-shift-y d) (list 1 0 0 0 1 d))
(define (nap-scale f) (list f 0 0 0 f 0))
(define (nap-scale-x f) (list f 0 0 0 1 0))
(define (nap-scale-y f) (list 1 0 0 0 f 0))
(define pi 3.1415926)
(define (nap-rotate-deg d)
(let* ((r (/ (* pi d) 180))
(c (cos r))
(s (sin r)))
(list c (- s) 0 s c 0)))

(test*
(define (almost-equal? ab pq)
(define (close x y) (< (abs (- x y)) 0.01))
(and (close a p) (close b q)))))
(let ((unit '#(1 0 0 0 1 0))
(incx2 (nap-shift-x 2))
(incy3 (nap-shift-y 3))
(double (nap-scale 2))
(scalex3 (nap-scale-x 3))
(scaley4 (nap-scale-y 4))
(rot90 (nap-rotate-deg 90))
(one '#(1 1)))
(expect* (equal? '#(3 1) (nap-transform-point incx2 one)))
(expect* (equal? '#(1 4) (nap-transform-point incy3 one)))
(expect* (equal? '#(2 2) (nap-transform-point double one)))
(expect* (equal? '#(3 1) (nap-transform-point scalex3 one)))
(expect* (equal? '#(1 4) (nap-transform-point scaley4 one)))
(expect* (almost-equal? '#(0.999 -0.001) '#(1 0)))
(expect* (almost-equal? '#(-1 1) (nap-transform-point rot90 one)))
(expect* (equal? '#(3 4) (nap-transform-point
(nap-join-transforms incx2 incy3) one)))))

; this wraps an engine and normalizes all transform actions
(define (nap-transform-handler engine)
(define (forward transform)
(engine 'nap-transform transform))
(lambda (action args)
(case action
((nap-shift-x) (forward (nap-shift-x (car args))))
((nap-shift-y) (forward (nap-shift-y (car args))))
((nap-scale) (forward (nap-scale (car args))))
((nap-scale-x) (forward (nap-scale-x (car args))))
((nap-scale-y) (forward (nap-scale-y (car args))))
((nap-rotate-deg) (forward (nap-rotate-deg (car args))))
(else (engine action args)))))

(define (speed n limit)
(if (> n limit)
'()
(let ((a (vector n n n n n n))
(b (vector n n n n n n)))
(nap-join-transforms a b)
(speed (+ n 1) limit))))

(define (measure n)
(display "warming up\n")
(speed 1 n)
(display (list n " timing\n"))
(time (speed 1 n)))

(measure 100000)

Andrew