Skip to content

Instantly share code, notes, and snippets.

@deeglaze
Last active July 20, 2019 14:11
Show Gist options
  • Save deeglaze/31bc02c325acdef4d67daec8c3af06e1 to your computer and use it in GitHub Desktop.
Save deeglaze/31bc02c325acdef4d67daec8c3af06e1 to your computer and use it in GitHub Desktop.
working out the definition of Racket's to-be standard-cat
#lang racket
(require pict/color)
(provide
(contract-out
[cat-silhouette
(->i ([width positive?] [height positive?])
(#:left-ear-extent [left-ear-extent (>=/c 0)]
#:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
#:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
#:right-ear-extent [right-ear-extent (>=/c 0)]
#:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
#:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
#:color [color (or/c color/c #f)]
#:border-color [border-color (or/c #f color/c)]
#:border-width [border-width (or/c #f (real-in 0 255))])
#:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
(ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
(values [_ pict?]
[_ (-> (or/c (cons/c real? real?) (is-a?/c point%))
(cons/c real? real?))]))]
[standard-cat/transform
(->i ([width positive?] [height positive?])
(#:left-ear-extent [left-ear-extent (>=/c 0)]
#:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
#:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
#:right-ear-extent [right-ear-extent (>=/c 0)]
#:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
#:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
#:fur-color [fur-color (or/c #f color/c)]
#:fur-border-color [fur-border-color (or/c #f color/c)]
#:lip-color [lip-color (or/c #f color/c)]
#:lip-border-color [lip-border-color color/c]
#:lip-border-width [lip-border-width (or/c #f (real-in 0 255))]
#:eye-color [eye-color (or/c #f color/c)]
#:nose-color [nose-color (or/c #f color/c)]
#:nose [nose pict?]
#:happy? [happy? any/c]
#:eyes [eyes (or/c #f pict?)]
#:left-eye [left-eye (eyes) (if eyes (or/c #f pict?) pict?)]
#:right-eye [right-eye (eyes) (if eyes (or/c #f pict?) pict?)]
#:whisker-length [whisker-length positive?]
#:whisker-droop [whisker-droop real?]
;; #f to hide whiskers
#:whisker-width [whisker-width (or/c #f (real-in 0 255))]
#:whisker-color [whisker-color color/c]
#:whisker-inset? [whisker-inset? any/c]
;; #f for no border
#:border-width [border-width (or/c #f (real-in 0 255))])
#:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
(ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
(values [_ pict?]
[_ (-> (or/c (cons/c real? real?) (is-a?/c point%))
(cons/c real? real?))]))]
[standard-cat
(->i ([width positive?] [height positive?])
(#:left-ear-extent [left-ear-extent (>=/c 0)]
#:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
#:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
#:right-ear-extent [right-ear-extent (>=/c 0)]
#:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
#:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
#:fur-color [fur-color (or/c #f color/c)]
#:fur-border-color [fur-border-color (or/c #f color/c)]
#:lip-color [lip-color (or/c #f color/c)]
#:lip-border-color [lip-border-color color/c]
#:lip-border-width [lip-border-width (or/c #f (real-in 0 255))]
#:eye-color [eye-color (or/c #f color/c)]
#:nose-color [nose-color (or/c #f color/c)]
#:nose [nose pict?]
#:happy? [happy? any/c]
#:eyes [eyes (or/c #f pict?)]
#:left-eye [left-eye (eyes) (if eyes (or/c #f pict?) pict?)]
#:right-eye [right-eye (eyes) (if eyes (or/c #f pict?) pict?)]
#:whisker-length [whisker-length positive?]
#:whisker-droop [whisker-droop real?]
;; #f to hide whiskers
#:whisker-width [whisker-width (or/c #f (real-in 0 255))]
#:whisker-color [whisker-color color/c]
#:whisker-inset? [whisker-inset? any/c]
;; #f for no border
#:border-width [border-width (or/c #f (real-in 0 255))])
#:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
(ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
[_ pict?])]
[happy-eyes (->* (positive? positive?)
(#:boldness (real-in 0 1)
#:color (or/c #f color/c)
#:border-color color/c
#:border-width (or/c #f (real-in 0 255)))
pict?)]))
(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 (polar r θ)
(cons (* r (cos θ)) (* r (sin θ))))
(define (default-ear-extent height) (/ height 4))
(define default-ear-arc (* pi 1/4))
(define (default-left-ear-angle left-ear-arc)
(- (* 2/3 pi) (/ left-ear-arc 2)))
(define (default-right-ear-angle right-ear-arc)
(- (* 1/3 pi) (/ right-ear-arc 2)))
(define (cat-silhouette width height
;; How much farther than the circle does the ear extend?
#:left-ear-extent [left-ear-extent (default-ear-extent height)]
;; How much of an arc does the ear sweep out?
#:left-ear-arc [left-ear-arc default-ear-arc]
;; At what angle do we start drawing the ear?
#:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
#:right-ear-extent [right-ear-extent (default-ear-extent height)]
#:right-ear-arc [right-ear-arc default-ear-arc]
#:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
#:color [color "orange"]
#:border-color [border-color (make-object color% 200 80 100)]
#:border-width [border-width 1])
(define x-radius (/ width 2))
(define y-radius (/ height 2))
(define left-ear-tip
(polar (+ left-ear-extent x-radius) (+ left-ear-angle (/ left-ear-arc 2))))
(define right-ear-tip
(polar (+ right-ear-extent x-radius) (+ right-ear-angle (/ right-ear-arc 2))))
;; All calculations done in cat-face-center-is-(0,0) coordinates.
(define left-protrusion
(min (- x-radius) (car left-ear-tip) (car right-ear-tip)))
(define right-protrusion
(max x-radius (car right-ear-tip) (car left-ear-tip)))
(define top-protrusion
(max y-radius (cdr left-ear-tip) (cdr right-ear-tip)))
(define bottom-protrusion
(min (- y-radius) (cdr left-ear-tip) (cdr right-ear-tip)))
;; All protrusions affect what the overall coordinate space is.
;; If an ear extends past the leftmost or topmost extent of the base circle,
;; then all coordinates must be adjusted by the difference from the circle.
;; If an ear extends past the rightmost or bottommost extent of the circle,
;; that difference (plus the left/top difference) add to the width and
;; height of the image.
;; The left and top protrusions are what shift our coordinate space.
;; The right and bottom protrusions possibly add to the overall width
;; and height.
(define adjust-left (+ (- (max 0 (+ left-protrusion x-radius)))
(or border-width 0)))
(define adjust-top (max 0 (- (+ (or border-width 0) top-protrusion)
y-radius)))
(define (from-cat-coords point)
(match-define (cons x y)
(cond [(pair? point) point]
[else (cons (send point get-x) (send point get-y))]))
(cons (+ x adjust-left x-radius) (- (+ y-radius adjust-top) y)))
(define left-ear-end
(from-cat-coords
(ellipse-point width height (+ left-ear-angle left-ear-arc))))
(define right-ear-end
(from-cat-coords
(ellipse-point width height (+ right-ear-angle right-ear-arc))))
(define width*
(+ adjust-left x-radius right-protrusion (or border-width 0)))
(define height*
(+ adjust-top y-radius (- bottom-protrusion) (or border-width 0)))
(values
(draw-shape/border width*
height*
(λ (dc dx dy)
(define cat-path (new dc-path%))
(send cat-path arc
adjust-left adjust-top
width height
(+ left-ear-angle left-ear-arc)
right-ear-angle)
(send cat-path lines
(list (from-cat-coords right-ear-tip)
right-ear-end))
(send cat-path arc
adjust-left adjust-top
width height
(+ right-ear-angle right-ear-arc)
left-ear-angle)
(send cat-path lines
(list (from-cat-coords left-ear-tip)
left-ear-end))
(send cat-path close)
(send dc draw-path cat-path dx dy))
color border-color border-width
#:draw-border? border-width
#:transparent? (not color))
from-cat-coords))
;; ear-positioning-errors: 4 reals -> #f or Listof[String]
;; Checks for errors in a cat's ear positioning. Error messages are
;; returned as a list of strings (descriptions of the errors).
(define (ear-positioning-errors in-left-ear-arc in-left-ear-angle
in-right-ear-arc in-right-ear-angle)
(define left-ear-arc (if (unsupplied-arg? in-left-ear-arc)
default-ear-arc
in-left-ear-arc))
(define left-ear-angle (if (unsupplied-arg? in-left-ear-angle)
(default-left-ear-angle left-ear-arc)
in-left-ear-angle))
(define right-ear-arc (if (unsupplied-arg? in-right-ear-arc)
default-ear-arc
in-right-ear-arc))
(define right-ear-angle (if (unsupplied-arg? in-right-ear-angle)
(default-right-ear-angle right-ear-arc)
in-right-ear-angle))
(define messages
(list
(and (< left-ear-angle right-ear-angle)
(list "Left ear is to the right of the right ear"))
(and (> (+ left-ear-arc right-ear-arc) (* 2 pi))
(list "Ear arcs cannot exceed 2pi"))
(and (> (+ right-ear-angle right-ear-arc) left-ear-angle)
(list "Right ear cannot overlap with left ear"))
(and (> (+ left-ear-angle left-ear-arc) (+ (* 2 pi) right-ear-angle))
(list "Left ear cannot overlap with right ear"))))
(define errors (filter values messages))
(or (null? errors) errors))
(define (happy-eyes width height
#:boldness [boldness 0.2]
#:color [color "black"]
#:border-color [border-color "black"]
#:border-width [border-width #f])
;; More boldness = less height for the smaller ellipse.
(define height-percent (- 1 boldness))
(unless (< 0 boldness 1)
(error 'happy-eyes "Boldness must be between 0 and 1 exclusive"))
(draw-shape/border width height
(lambda (dc dx dy)
(define eye-path (new dc-path%))
(send eye-path arc 0 0 width height 0 pi)
(send eye-path arc 0 (* height boldness)
width (* height height-percent) pi 0 #f)
(send eye-path close)
(send dc draw-path eye-path dx dy))
color border-color border-width
#:draw-border? border-width
#:transparent? (not color)))
(define (standard-cat/transform width height
#:left-ear-extent [left-ear-extent (default-ear-extent height)]
#:left-ear-arc [left-ear-arc default-ear-arc]
#:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
#:right-ear-extent [right-ear-extent (default-ear-extent height)]
#:right-ear-arc [right-ear-arc default-ear-arc]
#:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
#:fur-color [fur-color "orange"]
#:fur-border-color [fur-border-color (make-object color% 200 80 100)]
#:eye-color [eye-color "black"]
#:nose-color [nose-color "pink"]
#:nose [nose (equilateral-triangle (/ width 4) (/ height 4) #:angle pi #:color nose-color)]
#:lip-color [lip-color (make-object color% 240 140 0)]
#:lip-border-color [lip-border-color fur-border-color]
#:lip-border-width [lip-border-width 1]
#:happy? [happy? #f]
#:eyes [eyes
(if happy?
(happy-eyes (/ width 6) (/ height 6) #:color eye-color)
(filled-ellipse (/ width 6) (/ height 6) #:color eye-color))]
#:left-eye [left-eye #f]
#:right-eye [right-eye #f]
#:whisker-length [whisker-length (* 3/8 width)]
#:whisker-droop [whisker-droop (* 1/6 height)]
#:whisker-color [whisker-color (make-object color% 100 40 50)]
#:whisker-width [whisker-width 1]
#:whisker-inset? [whisker-inset? #t]
#:border-width [border-width 1])
(define-values (face coord-fn)
(cat-silhouette width height
#:left-ear-extent left-ear-extent
#:left-ear-arc left-ear-arc
#:left-ear-angle left-ear-angle
#:right-ear-extent right-ear-extent
#:right-ear-arc right-ear-arc
#:right-ear-angle right-ear-angle
#:color fur-color
#:border-color fur-border-color
#:border-width border-width))
(match-define (cons pre-center-x center-y) (coord-fn (cons 0 0)))
(define left-whisker-center-offset
(* -3/4 (pict-width nose)))
(define left-whisker-extent-from-center
(+ (- whisker-length) left-whisker-center-offset))
(define left-whisker-inset-amount
(if whisker-inset?
(max 0 (- (car (coord-fn (cons left-whisker-extent-from-center 0)))))
0))
(define right-whisker-center-offset
(* 3/4 (pict-width nose)))
(define right-whisker-extent-from-center
(+ whisker-length right-whisker-center-offset))
(define right-whisker-inset-amount
(if whisker-inset?
(max 0 (- (car (coord-fn (cons right-whisker-extent-from-center 0)))
(pict-width face)))
0))
;; If we don't show the whiskers, we don't need to inset the face
;; in order to draw them past the extent of the cat silhouette.
(define-values (center-x face*)
(cond [(not whisker-width) (values pre-center-x face)]
[else
(define inset-face
(inset face left-whisker-inset-amount 0
right-whisker-inset-amount 0))
(values (+ pre-center-x left-whisker-inset-amount)
inset-face)]))
(define face-and-nose
(pin-over face*
(- center-x (/ (pict-width nose) 2))
(- center-y (/ (pict-height nose) 2))
nose))
(define lip
(draw-shape/border (/ width 4) (/ height 4)
(λ (dc dx dy)
(send dc draw-arc dx dy (/ width 4) (/ height 4) pi 0))
lip-color lip-border-color lip-border-width
#:draw-border? lip-border-width
#:transparent? (not lip-color)))
(define left-lip
(pin-over face-and-nose
(- center-x (pict-width lip))
center-y
lip))
(define lips
(pin-over left-lip center-x center-y lip))
(define select-left-eye (or left-eye eyes))
(define with-left-eye
(pin-over lips
(- center-x (pict-width select-left-eye) (/ (pict-width nose) 2))
(- center-y (pict-height nose))
select-left-eye))
(define with-eyes
(pin-over with-left-eye
(+ center-x (/ (pict-width nose) 2))
(- center-y (pict-height nose))
(or right-eye eyes)))
(cond
[(not whisker-width) (values with-eyes coord-fn)]
[else
(define left-whisker
(draw-shape/border
(/ width 2) (/ height 16)
(λ (dc dx dy)
(send dc draw-spline dx dy
(- dx (* 5/8 whisker-length))
(+ dy (* 1/16 height))
(- dx whisker-length)
(+ dy whisker-droop)))
#f whisker-color whisker-width
#:draw-border? whisker-width
#:transparent? #f))
(define right-whisker
(draw-shape/border
(/ width 2) (/ height 16)
(λ (dc dx dy)
(send dc draw-spline dx dy
(+ dx (* 5/8 whisker-length))
(+ dy (* 1/16 height))
(+ dx whisker-length)
(+ dy whisker-droop)))
#f whisker-color whisker-width
#:draw-border? whisker-width
#:transparent? #f))
(define with-whisker0
(pin-over with-eyes
(- center-x (/ (pict-width nose) 2))
(+ center-y (/ (pict-height nose) 2))
left-whisker))
(define with-whisker1
(pin-over with-whisker0
(+ center-x left-whisker-center-offset)
(+ center-y (* 1/4 (pict-height nose)))
left-whisker))
(define with-whisker2
(pin-over with-whisker1
(+ center-x (/ (pict-width nose) 2))
(+ center-y (/ (pict-height nose) 2))
right-whisker))
(values
(pin-over with-whisker2
(+ center-x right-whisker-center-offset)
(+ center-y (* 1/4 (pict-height nose)))
right-whisker)
(λ (pair)
(match-define (cons dx dy) (coord-fn pair))
(cons (+ left-whisker-inset-amount dx) dy)))]))
(define (standard-cat width height
#:left-ear-extent [left-ear-extent (default-ear-extent height)]
#:left-ear-arc [left-ear-arc default-ear-arc]
#:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
#:right-ear-extent [right-ear-extent (default-ear-extent height)]
#:right-ear-arc [right-ear-arc default-ear-arc]
#:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
#:fur-color [fur-color "orange"]
#:fur-border-color [fur-border-color (make-object color% 200 80 100)]
#:eye-color [eye-color "black"]
#:nose-color [nose-color "pink"]
#:nose [nose (equilateral-triangle (/ width 4) (/ height 4) #:angle pi #:color nose-color)]
#:lip-color [lip-color (make-object color% 240 140 0)]
#:lip-border-color [lip-border-color fur-border-color]
#:lip-border-width [lip-border-width 1]
#:happy? [happy? #f]
#:eyes [eyes
(if happy?
(happy-eyes (/ width 6) (/ height 6) #:color eye-color)
(filled-ellipse (/ width 6) (/ height 6) #:color eye-color))]
#:left-eye [left-eye #f]
#:right-eye [right-eye #f]
#:whisker-length [whisker-length (* 3/8 width)]
#:whisker-droop [whisker-droop (* 1/6 height)]
#:whisker-color [whisker-color (make-object color% 100 40 50)]
#:whisker-width [whisker-width 1]
#:whisker-inset? [whisker-inset? #t]
#:border-width [border-width 1])
(define-values (cat _) (standard-cat/transform
width height
#:left-ear-extent left-ear-extent
#:left-ear-arc left-ear-arc
#:left-ear-angle left-ear-angle
#:right-ear-extent left-ear-extent
#:right-ear-arc right-ear-arc
#:right-ear-angle right-ear-angle
#:fur-color fur-color
#:fur-border-color fur-border-color
#:eye-color eye-color
#:nose-color nose-color
#:nose nose
#:lip-color lip-color
#:lip-border-color lip-border-color
#:happy? happy?
#:eyes eyes
#:left-eye left-eye
#:right-eye right-eye
#:whisker-length whisker-length
#:whisker-droop whisker-droop
#:whisker-color whisker-color
#:whisker-width whisker-width
#:whisker-inset? whisker-inset?
#:border-width border-width))
cat)
;; Wink!
(standard-cat 50 90 #:happy? #t #:left-eye (filled-ellipse (/ 50 6) (/ 90 6)))
@spdegabrielle
Copy link

Awesome!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment