Skip to content

Instantly share code, notes, and snippets.

@deeglaze
Last active October 16, 2017 03:46
Show Gist options
  • Save deeglaze/1fdb2a6e9878fc272b959c766e3828de to your computer and use it in GitHub Desktop.
Save deeglaze/1fdb2a6e9878fc272b959c766e3828de to your computer and use it in GitHub Desktop.
working out the math for standard-dog
#lang racket
(require pict racket/draw)
;; Not exported by pict/private/utils.rkt
(define (draw-shape/border w h draw-fun
color [border-color #f] [border-width #f]
#:draw-border? [draw-border? #t]
#:transparent? [transparent? #f])
(dc (λ (dc dx dy)
(define old-brush (send dc get-brush))
(define old-pen (send dc get-pen))
(send dc set-brush
(send the-brush-list find-or-create-brush
(cond [transparent? "white"]
[color color]
[else (send old-pen get-color)])
(if transparent? 'transparent 'solid)))
(if draw-border?
(when (or border-color border-width)
;; otherwise, leave pen as is
(send dc set-pen (send the-pen-list
find-or-create-pen
(or border-color
(send old-pen get-color))
(or border-width
(send old-pen get-width))
(send old-pen get-style))))
(send dc set-pen "black" 1 'transparent))
(draw-fun dc dx dy)
(send dc set-brush old-brush)
(send dc set-pen old-pen))
w h))
;; ellipse-point: positive? positive? real? [real? real?] -> (is/a point%)
;; Creates a point% representing the x,y coordinates on an ellipse that
;; fills the rectangle (0,0)-(width,height), then offsets the result by
;; (offset-x, offset-y).
(define (ellipse-point width height θ [offset-x 0] [offset-y 0])
(make-object point% (+ offset-x (* (/ width 2) (cos θ)))
(+ offset-y (* (/ height 2) (sin θ)))))
;; circumscribed-triangle: real? real? -> pict?
;; Draws a triangle whose points lie on an ellipse filling the rectangle
;; (0,0)-(width,height). Each point is positioned by its angular position.
;; The triangle may be optionally filled with a #:color argument. If given
;; a positive #:border-width argument, the triangle will have a border of
;; color #:border-color.
(define (circumscribed-triangle width height
#:angle0 [angle0 (/ pi 2)]
#:angle1 [angle1 (+ angle0 (* 2/3 pi))]
#:angle2 [angle2 (+ angle1 (* 2/3 pi))]
#:color [color #f]
#:border-color [border-color "black"]
#:border-width [border-width #f])
(draw-shape/border width height
(λ (dc dx dy)
(define radius (/ (min width height) 2))
(send dc draw-polygon
(list (ellipse-point width height angle0 dx dy)
(ellipse-point width height angle1 dx dy)
(ellipse-point width height angle2 dx dy))
(/ width 2) (/ height 2)))
color border-color border-width
#:draw-border? (or border-color border-width)
#:transparent? (not color)))
;; equilateral-triangle: draws a circumscribed triangle with all points
;; equidistant from each other on the circle. The triangle can be optionally
;; rotated.
(define (equilateral-triangle width height
#:angle [angle 0]
#:color [color #f]
#:border-color [border-color #f])
(circumscribed-triangle width height
#:angle0 (+ (/ pi 2) angle)
#:angle1 (+ (/ pi 2) angle (* 2/3 pi))
#:angle2 (+ (/ pi 2) angle (* 4/3 pi))
#:color color #:border-color border-color
#:border-width (and border-color 1)))
(define width 50)
(define height 50)
(define ear-width 12)
(define ear-length 30)
;; Let r be the base radius, f be the fraction along the radius for the cheek,
;; θ be the angle the radius magnitude vector points, and L be the fraction of
;; the radius that the cheek is.
;;
;; The chosen values for L and f mean the existence or finiteness of a
;; solution.
;; A cheek too big would envelope the base (0 solutions)
;; A cheek too small would be eveloped by the base (0 solutions)
;; A cheek the same size as the base and not offset from center would mean
;; that any ϑ, ψ such that ϑ = ψ is a solution.
;; An offset too large means the circles don't intersect at all (0 solutions)
;; (this is actually covered by the size problems above)
;; The offset is exactly the sum of both radii (1 solution)
;; A non-positive radius is absurd.
;;
;; Let's make the third case illegal off the bat: f, L must be such that
;; f != 0 or L != 1. (*1)
;; Absurdity avoidance: L > 0 (*2)
;; 1 solution avoidance: |f| < (1 + L) (*3)
;;
;; A cheek too big means that the cheek radius (L*r) is greater than the base
;; radius (r) plus the magnitude of the offset (|f|*r): L*r > (1 + |f|)*r.
;; In other words, travel away from the origin f*r-many units, then L*r is
;; greater than both the distance to get back, but also the distance to any
;; point on the base circle (which is r away from that).
;; Therefore, L*r > (|f| + 1)*r is too big. Cancel rs on both sides and ensure
;; the condition is unsatisfiable by the constraint
;; L - |f| <= 1 (*4)
;;
;; A base too big is a similar story (contrapositive, cheek is too small).
;; The radius (r) is greater than both the distance from the center (|f|*r) and
;; the farthest the cheek can get from that (L*r): r > (|f| + L)*r. Cancel rs on
;; both sides and ensure the condition is unsatisfiable by the constraint
;; 1 <= L + |f| (*5)
;;
;; The corrolaries that follow from their combination mean
;; f = 0 => L = 1 (by *4, *5), but (by *1) this is absurd.
;; thus f != 0 always (*6)
;;
;; 1 > |f| - L >= -1 (by *3, *4)
;;
;; So TRIANGLES, we have a triangle with a base along the f ray (call its
;; length a) and a side normal to that that intersects the 2 circles' point
;; of intersection. Call the length of this normal h. The rest of the distance
;; to the second circle is b (f*r - a).
;;
;; distance d between circles' centers: d = a + b = |f|*r
;; a^2 + h^2 = r^2
;; b^2 + h^2 = (L*r)^2
;; Thus r^2 - a^2 = (L*r)^2 - b^2
;; solve for a,
;; a = (r^2 - (L*r)^2 + (|f|*r)^2) / (2*|f|*r)
;; = (r - L^2*r + f^2*r) / 2*|f|
;; = r(1 - L^2 + f^2) / 2|f|
;; So the angle from the base circle is atan(h / a) + θ
;; The angle from the cheek circle is
;; atan(h / b) + θ + pi = atan(h / (f*r - a)) + θ + pi
(define (circle-intersections a b h [θ 0])
(values (+ θ (atan h a)) (+ θ (atan (- h) a))
(+ pi θ (atan h b))
(+ pi θ (atan (- h) b))))
(define (face-cheek-intersections L r f θ)
(define absf (abs f))
(define L2 (* L L))
(define f2 (* f f))
(define r2 (* r r))
(define a (/ (* r (+ (- 1 L2) f2)) (* 2 absf)))
(define b (- (* f r) a))
(define a2 (* a a))
(define h (sqrt (- r2 a2)))
(circle-intersections a b h θ))
;; The distance between two cheeks follows the cosine law
;; d^2 = cheek_distance0^2 +
;; cheek_distance1^2 -
;; 2*cheek_distance0*cheek_distance1*cos(ϕ)
;;
;; where ϕ comes from the dot product of the two cheek vectors;
;; cheek0 . cheek1
;; ={def}
;; cheek0.x*cheek1.x + cheek0.y*cheek1.y
;; ={linear alg}
;; cheek_distance0*cheek_distance1*cos(ϕ)
;;
;; cheek_distance0 = |f0|*radius
;; cheek_distance1 = |f1|*radius
;; cheek0 = (radius + f0*radius*cos(θ0), radius + f0*radius*sin(θ0))
;; cheek1 = (radius + f1*radius*cos(θ1), radius + f1*radius*sin(θ1))
;;
;; a^2 + h^2 = (L0*r)^2
;; b^2 + h^2 = (L1*r)^2
;; a = ((L0*r)^2 - (L1*r)^2 + d^2) / 2*d
(define (cheek-cheek-intersections r L0 f0 L1 f1 θ0 θ1)
(define d2 (+ (sqr (* r f0)) (sqr (* r f1))))
(define L0r^2 (sqr (* r L0)))
(define L1r^2 (sqr (* r L1)))
;; Both f0 = 0 and f1 = 0 are ruled out, so d2 != 0
(define a (/ (+ (- L0r^2 L1r^2) d2) (* 2 (sqrt d2))))
(define h2 (- L0r^2 (sqr a)))
(define h (sqrt h2))
(define b (sqrt (- L1r^2 h2)))
(circle-intersections a b h))
(define (op-car op initial lst)
(for/fold ([acc `(,initial . #f)])
([which (in-list lst)])
(if (op (car which) (car acc))
which
acc)))
(define (min-car lst) (op-car < +inf.0 lst))
(define (max-car lst) (op-car > -inf.0 lst))
(let* ([radius 50]
[L 3/4]
[cheek-radius (* L radius)]
[radius-fraction 5/8]
[border-width 3]
[color "darkred"]
[border-color "red"]
[θleft (* 5/4 pi)]
[θright (* 7/4 pi)])
(define-values (Rface0 Rface1 Rcheek0 Rcheek1)
(face-cheek-intersections L radius radius-fraction θright))
(define-values (Lface0 Lface1 Lcheek0 Lcheek1)
(face-cheek-intersections L radius radius-fraction θleft))
(define-values (LRcheek0 LRcheek1 RLcheek0 RLcheek1)
(cheek-cheek-intersections radius L radius-fraction L radius-fraction θleft θright))
(define Rcheek-center
(make-object point%
(+ radius (* radius-fraction radius (cos θright)))
(- radius (* radius-fraction radius (sin θright)))))
(define Rcheek-x (- (send Rcheek-center get-x) cheek-radius))
(define Rcheek-y (- (send Rcheek-center get-y) cheek-radius))
(define Lcheek-center
(make-object point%
(+ radius (* radius-fraction radius (cos θleft)))
(- radius (* radius-fraction radius (sin θleft)))))
(define Lcheek-x (- (send Lcheek-center get-x) cheek-radius))
(define Lcheek-y (- (send Lcheek-center get-y) cheek-radius))
(define border-width* (or border-width 0))
(define protrude-left
(max border-width* (+ (- Lcheek-x) border-width*) (+ (- Rcheek-x) border-width*)))
(define protrude-top
(max border-width* (+ (- Lcheek-y) border-width*) (+ (- Rcheek-y) border-width*)))
(define protrude-right
(max border-width*
(- (+ Rcheek-x (* 2 cheek-radius) border-width*) (* 2 radius))
(- (+ Lcheek-x (* 2 cheek-radius) border-width*) (* 2 radius))))
(define protrude-bottom
(max border-width*
(- (+ Rcheek-y (* 2 cheek-radius) border-width*) (* 2 radius))
(- (+ Lcheek-y (* 2 cheek-radius) border-width*) (* 2 radius))))
(define dog-path (new dc-path%))
;; Base face.
;; Walk around the base face to find the minimum angle.
(define walk0
(min-car `((,Lface0 . Lcheek)
(,Lface1 . Lcheek)
(,Rface1 . Rface))))
(send dog-path arc protrude-left protrude-top
(* 2 radius) (* 2 radius) Rface0 (car walk0))
;; Lface0 getting selected means we draw the left cheek.
(unless (eq? (cdr walk0) 'Lcheek) (error 'dog "woops ~a" (cdr walk0)))
(define walk1
(min-car `((,LRcheek0 . Lcheek)
(,LRcheek1 . Lcheek)
(,Lcheek1 . face))))
(unless (eq? (cdr walk0) 'Lcheek) (error 'dog "dang ~a" (cdr walk1)))
(send dog-path arc
(+ protrude-left Lcheek-x) (+ protrude-top Lcheek-y)
(* 2 cheek-radius) (* 2 cheek-radius) Lcheek0 (car walk1))
;; If walk1 were face, then we'd draw the face arc from Lcheek intersection
;; to Rcheek intersection, then start drawing Rcheek. But, we didn't, so
;; now we draw from LRcheek. Rcheek0 we know is contained in the surface
;; because the Lcheek intersected the Rcheek before the face.
(define walk2 (max-car `((,RLcheek0 . Rcheek) (,RLcheek1 . Rcheek))))
(send dog-path arc
(+ protrude-left Rcheek-x) (+ protrude-top Rcheek-y)
(* 2 cheek-radius) (* 2 cheek-radius) (car walk2) Rcheek1)
(send dog-path close)
(define path-pict
(draw-shape/border
(+ protrude-left (* 2 radius) protrude-right)
(+ protrude-top (* 2 radius) protrude-bottom)
(λ (dc dx dy) (send dc draw-path dog-path dx dy))
color border-color border-width
#:draw-border? border-width
#:transparent? #f))
path-pict)
;; length measured from center of face.
(define snout-length 90)
;; (0, 1] interval for how much of the face the snout takes up.
(define snout-face-fraction 0.5)
;; A threshold amount of how much of the snout is rounded.
;; 0 means a sharp edge snout, 1 means a half circle edge snout.
;; This means snout-curvature * snout-width * 0.5 is the radius of the
;; curved circle ends of the snout.
(define snout-curvature 0.25)
;; Depending on the width and length of the snout, the ears may curve
;; all the way around the end and come back up toward the face. The
;; lines of the earl
(define snout-width (* width snout-face-fraction))
(define (try0 width height ear-width ear-length snout-length)
(define dog-path (new dc-path%))
;; curve of right ear
(send dog-path arc width (/ height 2) (* 2 ear-width) (* 2 ear-width) 0 (/ pi 2))
;; crown
(send dog-path arc ear-width 0 width height 0 pi)
;; top curve of left ear
(send dog-path arc 0 (/ height 2) (* 2 ear-width) (* 2 ear-width) (/ pi 2) pi)
;; length of the left ear
(send dog-path line-to 0
(+ (/ height 2) ear-width
;; The tips of the ears form a full circle with diameter 2*ear-width.
(- ear-length (* 2 ear-width))))
;; bottom curve of the left ear
(send dog-path arc 0
(+ (/ height 2) ear-width ear-length)
ear-width
ear-width
pi 0)
(send dog-path line-to (* 2 ear-width) (+ snout-length (/ height 2)))
(send dog-path close)
(dc (λ (dc dx dy) (send dc draw-path dog-path dx dy))
(+ (* 2 ear-width) width)
(+ (max height (+ (/ height 2) ear-width))
(max 0 (- snout-length (/ height 2)) (+ ear-length ear-width)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment