| Andrew Cooke | Contents | Latest | RSS | Twitter | Previous | Next

C[omp]ute

Welcome to my blog, which was once a mailing list of the same name and is still generated by mail. Please reply via the "comment" links.

Always interested in offers/projects/new ideas. Eclectic experience in fields like: numerical computing; Python web; Java enterprise; functional languages; GPGPU; SQL databases; etc. Based in Santiago, Chile; telecommute worldwide. CV; email.

Personal Projects

Lepl parser for Python.

Colorless Green.

Photography around Santiago.

SVG experiment.

Professional Portfolio

Calibration of seismometers.

Data access via web services.

Cache rewrite.

Extending OpenSSH.

C-ORM: docs, API.

Last 100 entries

Why Information Grows; The Blindness Of The Chilean Elite; Some Victoriagate Links; This Is Why I Left StackOverflow; New TLS Implementation; Maths for Physicists; How I Am 8; 1000 Word Philosophy; Cyberpunk Reading List; Detailed Discussion of Message Dispatch in ParserCombinator Library for Julia; FizzBuzz in Julia w Dependent Types; kokko - Design Shop in Osaka; Summary of Greece, Currently; LLVM and GPUs; See Also; Schoolgirl Groyps (Maths); Japanese Lit; Another Example - Modular Arithmetic; Music from United; Read Agatha Christie for the Plot; A Constructive Look at TempleOS; Music Thread w Many Recommendations; Fixed Version; A Useful Julia Macro To Define Equality And Hash; k3b cdrom access, OpenSuse 13.1; Week 2; From outside, the UK looks less than stellar; Huge Fonts in VirtualBox; Keen - Complex Emergencies; The Fallen of World War II; Some Spanish Fiction; Calling C From Fortran 95; Bjork DJ Set; Z3 Example With Python; Week 1; Useful Guide To Starting With IJulia; UK Election + Media; Review: Reinventing Organizations; Inline Assembly With Julia / LLVM; Against the definition of types; Dumb Crypto Paper; The Search For Quasi-Periodicity...; Is There An Alternative To Processing?; CARDIAC (CARDboard Illustrative Aid to Computation); The Bolivian Case Against Chile At The Hague; Clear, Cogent Economic Arguments For Immigration; A Program To Say If I Am Working; Decent Cards For Ill People; New Photo; Luksic And Barrick Gold; President Bachelet's Speech; Baltimore Primer; libxml2 Parsing Stream; configure.ac Recipe For Library Path; The Davalos Affair For Idiots; Not The Onion: Google Fireside Chat w Kissinger; Bicycle Wheels, Inertia, and Energy; Another Tax Fraud; Google's Borg; A Verion That Redirects To Local HTTP Server; Spanish Accents For Idiots; Aluminium Cans; Advice on Spray Painting; Female View of Online Chat From a Male; UX Reading List; S4 Subgroups - Geometric Interpretation; Fucking Email; The SQM Affair For Idiots; Using Kolmogorov Complexity; Oblique Strategies in bash; Curses Tools; Markov Chain Monte Carlo Without all the Bullshit; Email Para Matias Godoy Mercado; The Penta Affair For Idiots; Example Code To Create numpy Array in C; Good Article on Bias in Graphic Design (NYTimes); Do You Backup github?; Data Mining Books; SimpleDateFormat should be synchronized; British Words; Chinese Govt Intercepts External Web To DDOS github; Numbering Permutations; Teenage Engineering - Low Price Synths; GCHQ Can Do Whatever It Wants; Dublinesque; A Cryptographic SAT Solver; Security Challenges; Word Lists for Crosswords; 3D Printing and Speaker Design; Searchable Snowden Archive; XCode Backdoored; Derived Apps Have Malware (CIA); Rowhammer - Hacking Software Via Hardware (DRAM) Bugs; Immutable SQL Database (Kinda); Tor GPS Tracker; That PyCon Dongle Mess...; ASCII Fluid Dynamics; Brandalism; Table of Shifter, Cassette and Derailleur Compatability; Lenovo Demonstrates How Bad HTTPS Is; Telegraph Owned by HSBC; Smaptop - Sunrise (Music)

© 2006-2015 Andrew Cooke (site) / post authors (content).

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)
  (license: gpl/v3.0))

(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)
  (receive (a as) (split lst)
    (receive (b bs) (split as)
      (receive (c cs) (split bs)
        (receive (d ds) (split cs)
          (receive (e es) (split ds)
            (receive (f fs) (split es)
              (values a b c d e f))))))))

(define (unpack2 lst)
  (receive (a as) (split lst)
    (receive (b bs) (split as)
      (values a b))))

(define (nap-transform-point transform point)
  (receive (a b c d e f) (unpack6 transform)
    (receive (x y) (unpack2 point)
      (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))
   (receive (a b) (unpack2 ab)
     (receive (p q) (unpack2 pq)
       (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)
  (license: gpl/v3.0))

(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))
   (receive (a b) (unpack2 ab)
     (receive (p q) (unpack2 pq)
       (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

Comment on this post