PasteRack.org
Paste # 74929
2017-10-09 01:49:13

Fork as a new paste.

Paste viewed 21 times.


Embed:

  1. #lang racket
  2. (require pict racket/draw)
  3.  
  4. (define ((pt->xform-obj width height angle) p)
  5.   (match p
  6.          [(list x y)
  7.           (define d (sqrt (+ (* x x) (* y y))))
  8.           (define a (atan y x))
  9.           (make-object point%
  10.                        (* d width 1/2 (cos (+ a angle)))
  11.                        (* d height 1/2 (- (sin (+ a angle)))))]))
  12.  
  13. ;; Draw an isoceles-triangle with base |width| and height |height|
  14. ;; rotated |angle| radians.
  15. (define (isoceles-triangle width height [angle 0])
  16.   (dc
  17.     (lambda (dc x y)
  18.       (let ([b (send dc get-brush)]
  19.             [p (send dc get-pen)])
  20.         (send dc set-pen (send the-pen-list
  21.                                find-or-create-pen
  22.                                (send p get-color)
  23.                                0
  24.                                'solid))
  25.         (send dc set-brush (send the-brush-list
  26.                                  find-or-create-brush
  27.                                  (send p get-color)
  28.                                  'solid))
  29.         (send dc draw-polygon
  30.               (map (pt->xform-obj width height angle)
  31.                    `((0 1)
  32.                      (-1/2 0)
  33.                      (1/2 0)))
  34.               (+ x (/ width 2)) (+ y height))
  35.         (send dc set-brush b)
  36.         (send dc set-pen p)))
  37.     width height))
  38.  
  39. ;; nose
  40. (isoceles-triangle 50 50 3.14)
  41. ;; left ear
  42. (isoceles-triangle 80 140 (* 3.14 1/3))
  43. ;; right ear
  44. (isoceles-triangle 80 140 (* -3.14 1/3))

=>

image

image

image