#lang racket (require slideshow/pict) ;; ============================================================ ;; A LIBRARY FOR DISTRIBUTING PICTS ALONG PATHS ;; pth ::= (pth (real? -> real?) (real? -> real?) real? real?) ;; a description of a finite (vector) path: a function that maps from ;; "time" to x-coordinate, another that maps from "time" to y-coordinate, ;; and minimum and maximum times that the path considers. (Here and ;; elsewhere, for clarity we describe picts "travelling" across a ;; given path over "time"; by this we just mean that we call "time" ;; the input to our path's component functions.) (struct pth (fx fy min max)) (define pict-or-pict-fn/c (or/c pict? (-> real? pict?))) (provide (contract-out (struct pth ((fx (-> real? real?)) (fy (-> real? real?)) (min real?) (max real?))) [path-between (->* (pict? pict? pict?) (#:origin-locator (-> pict? pict? (values real? real?)) #:destination-locator (-> pict? pict? (values real? real?))) pth?)] [distribute-between (->* (pict? pict? pict? (listof pict-or-pict-fn/c)) (#:origin-locator (-> pict? pict? (values real? real?)) #:destination-locator (-> pict? pict? (values real? real?)) #:rotate boolean?) pict?)] [distribute (->* (pth? (listof pict-or-pict-fn/c)) (#:divide (symbols 'evenly-across-domain 'evenly-across-range) #:rotate boolean?) pict?)])) ;; Internal representation of a mapping between a time and its corresponding x and y coordinates. (struct pt (t x y)) ;; path-between : pic pict pict [#:origin-locator xx-find] [#:destination-locator xx-find] -> pth? ;; Returns a path whose distance and direction corresponds to the (vector) distance from the first ;; pict to the second within the given scene. (define (path-between origin destination overall-pict #:origin-locator [find-origin-pt rc-find] #:destination-locator [find-destination-pt lc-find]) (let-values ([(origin-x origin-y) (find-origin-pt overall-pict origin)] [(destination-x destination-y) (find-destination-pt overall-pict destination)]) (let* ([function-domain-endpoint 1000] [scaled (λ (start end) (let ([delta (- end start)]) (λ (t) (* delta (/ t function-domain-endpoint)))))]) (pth (scaled origin-x destination-x) (scaled (- origin-y) (- destination-y)) ;; xx-find functions return inverted points 0 function-domain-endpoint)))) (define (distribute-between origin destination overall-pict objects-to-distribute #:origin-locator [find-origin-pt rc-find] #:destination-locator [find-destination-pt lc-find] #:rotate [rotate? #f]) (let* ([path (path-between origin destination overall-pict #:origin-locator find-origin-pt #:destination-locator find-destination-pt)] [distributed-pict (distribute path (append (cons (λ (a) (ghost origin)) objects-to-distribute) (list (λ (a) (ghost destination)))) #:rotate rotate?)]) (pin-over overall-pict origin find-origin-pt distributed-pict))) (define (distance p1 p2) (sqrt (+ (sqr (- (pt-x p2) (pt-x p1))) (sqr (- (pt-y p2) (pt-y p1)))))) (define (pairwise-distances samples) (let loop ([lefts samples] [rights (cdr samples)]) (cond [(null? rights) '()] [else (cons (distance (car lefts) (car rights)) (loop (cdr lefts) (cdr rights)))]))) (define epsilon 1) (define (within-tolerance? n) (< (abs n) epsilon)) ;; get-equal-domain-points : pth nat[>=2] -> (listof pt) ;; Returns the result of evaluating the pth function across n equally-spaced ;; points (define (evenly-across-domain pth n) (let* ([time-to-travel (- (pth-max pth) (pth-min pth))] [each-delta-t (/ time-to-travel (sub1 n))]) (for/list ([i n]) (let ([t (+ (pth-min pth) (* i each-delta-t))]) (pt t ((pth-fx pth) t) ((pth-fy pth) t)))))) ;; evenly-across-range : pth nat[>=2] -> (listof pt) ;; Returns n points that separate the arc described by path into equal lengths (define (evenly-across-range pth n) (let ([fx (pth-fx pth)] [fy (pth-fy pth)]) (let refine-samples ([attempt 1]) (let* ([numsamples (sub1 (* n (expt 2 attempt)))] [sample-width (/ (- (pth-max pth) (pth-min pth)) (sub1 numsamples))] [samples (for/list ([n numsamples]) (let ([t (+ (pth-min pth) (* sample-width n))]) (pt t (fx t) (fy t))))] [distances (pairwise-distances samples)] ; estimate total arc length [total-len (apply + distances)] [segment-len (/ total-len (sub1 n))] ;; TODO: make sure segment-len > tolerance ) (cond [(> (apply max distances) (+ segment-len epsilon)) (refine-samples (add1 attempt))] [else (let loop ([pts (cdr samples)] [ds distances] [pts-to-find n] [acc '()] [current-location (car samples)] [to-travel 0] [total-distance-to-travel total-len]) (cond [(= pts-to-find 0) (reverse acc)] [(within-tolerance? to-travel) (loop pts ds (sub1 pts-to-find) (cons current-location acc) current-location (+ segment-len to-travel) ;; add in the extra under/overshoot distance, so we can make it up total-distance-to-travel)] [(< to-travel 0) ;; we overshot, our estimate wasn't good enough, ;; try the whole thing over again with a larger sample ;; size (refine-samples (add1 attempt))] [else (loop (cdr pts) (cdr ds) pts-to-find acc (car pts) (- to-travel (car ds)) (- total-distance-to-travel (car ds)))]))]))))) ;; path->angle-finder : pth -> number? -> number? ;; determines the angle that an object would be facing if it were travelling ;; across pth from start to finish at time t. (define (path->angle-finder pth) (let ([dfx (derivative (pth-fx pth))] [dfy (derivative (pth-fy pth))]) (λ (t) (let* ([dy (dfy t)] [dx (dfx t)]) (if (= dx 0) ((if (> dy 0) + -) (/ pi 2)) (+ (atan (/ dy dx)) (if (< dx 0) pi 0))))))) ;; distibute : pth? (define (distribute path picters #:divide [get-points-sym 'evenly-across-range] #:rotate [rotate-plain-picts? #f]) (let* ([get-points (if (eq? get-points-sym 'evenly-across-domain) evenly-across-domain evenly-across-range)] [angle (path->angle-finder path)] [places (get-points path (length picters))] [origin (blank 1)]) (let loop ([picts picters] [pts places] [acc origin]) (cond [(null? picts) (panorama acc)] [else (let* ([pt (car pts)] [pict-or-pictfn (car picts)] [p (cond [(procedure? pict-or-pictfn) (if (procedure-arity-includes? pict-or-pictfn 2) (pict-or-pictfn (angle (pt-t pt)) (pt-t pt)) (pict-or-pictfn (angle (pt-t pt))))] [rotate-plain-picts? (rotate pict-or-pictfn (angle (pt-t pt)))] [else pict-or-pictfn])]) (loop (cdr picts) (cdr pts) (pin-over acc (pt-x pt) (- (pt-y pt)) p)))])))) ;; derivative : (real? -> real?) [real?] -> real? -> real? ;; Returns a function that numerically approximates the derivative of f based ;; on the standard formula (define (derivative f [h .0001]) (lambda (x) (/ (- (f (+ x h)) (f x)) h)))