working out the math for standard-dog

standard-dog.rkt

#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)))))