picts.rkt

#lang racket
(require pict
         pict/code
         pict/flash
         unstable/gui/pict
         racket/draw
         (for-syntax syntax/parse)
         syntax/parse/define
         ;; For contracting improper lists:
         (only-in racket/contract/private/rand rand-choice)
         (only-in racket/contract/private/generate generate/direct)
         (only-in racket/contract/private/guts define/subexpression-pos-prop))
(provide regular-polygon-points)

(define nonneg-real?
  (make-contract #:name 'nonnegative-real?
                 #:first-order (λ (x) (and (real? x) (>= x 0)))))
(define (within-width-and-height w h)
  (make-contract #:name (format "within width and height ~a ~a" w h)
                 #:first-order
                 (λ (rw)
                    (define 2v (* 2 rw))
                    (and (positive? (- w 2v))
                         (positive? (- h 2v))))))
(define (nondecreasing-listof c)
  (make-contract #:name `(nondecreasing-listof ,(contract-name c))
                 #:first-order
                 (λ (l) (and ((listof c) l) (apply <= l)))))

(define (list*of-generate elem-ctc)
  (λ (fuel)
     (define (mk-rand-list so-far)
       (rand-choice
         [1/5 so-far]
         [else (mk-rand-list (cons (generate/direct elem-ctc fuel) so-far))]))
     (mk-rand-list (if (= (random 5) 0) ;; improper with 20% probability
                       (generate/direct elem-ctc fuel)
                       '()))))

(define (for-each* f imp-lst)
  (match imp-lst
    ['() (void)]
    [(cons a d) (begin (f a) (for-each* f d))]
    [other (f other)]))

(define (map* f imp-lst)
  (match imp-lst
    ['() '()]
    [(cons a d) (cons (f a) (map* f d))]
    [other (f other)]))

(define-syntax (*-list*of stx)
  (syntax-parse stx
    [(_ predicate?:id name:expr generate:expr)
     (syntax
      (λ (input)
         (define ctc (coerce-contract 'name input))
         (define ctc-name (build-compound-type-name 'name ctc))
         (define proj (contract-projection ctc))
         (define (fo-check x)
           (and (predicate? x)
                (let loop ([x x])
                  (match x
                    ['() #t]
                    [(cons a d)
                     (and (contract-first-order-passes? ctc a)
                          (loop d))]
                    [other (contract-first-order-passes? ctc other)]))))
         (define ((ho-check check-all) blame)
           (let ([p-app (proj (blame-add-context blame "an element of"))])
             (λ (val)
                (unless (predicate? val)
                  (raise-blame-error blame val
                                     '(expected: "~s" given: "~e")
                                     'predicate? 
                                     val))
                (check-all p-app val))))
         (cond
          [(flat-contract? ctc)
           (make-flat-contract
            #:name ctc-name
            #:first-order fo-check
            #:projection (ho-check (λ (p v) (for-each* p v) v))
            #:generate (generate ctc))]
          [(chaperone-contract? ctc)
           (make-chaperone-contract
            #:name ctc-name
            #:first-order fo-check
            #:projection (ho-check map*)
            #:generate (generate ctc))]
          [else
           (make-contract
            #:name ctc-name
            #:first-order fo-check
            #:projection (ho-check map*))])))]))

(define list*of-func (*-list*of any/c list*of list*of-generate))
(define/subexpression-pos-prop (list*of x) (list*of-func x))

;; different constructors for coloring stuff
(provide/contract [list*of contract?]
                  [colorize-if (any/c pict? color/c . -> . pict?)]
                  [pin-over-center (pict? real? real? pict? . -> . pict?)]
                  [pin-under-center (pict? real? real? pict? . -> . pict?)]
                  [pin-over-vcenter (->* (pict? (or/c pict? real? pict-path?) (or/c procedure? real?) pict?)
                                         [#:x-translate real?]
                                         pict?)]
                  [pin-over-hcenter (->* (pict? (or/c pict? real? pict-path?) (or/c procedure? real?) pict?)
                                         [#:y-translate real?]
                                         pict?)]
                  [both ((boolean? . -> . void?) . -> . void?)]
                  [pin-under-all (pict? symbol? pict? . -> . pict?)]
                  [pin-over-tag (pict?
                                 (pict? pict-path? . -> . (values real? real?))
                                 symbol?
                                 (pict? . -> . pict?)
                                 . -> . pict?)]
                  [pin-under-tag (pict?
                                 (pict? pict-path? . -> . (values real? real?))
                                 symbol?
                                 (pict? . -> . pict?)
                                 . -> . pict?)]
                  ;; Better than ellipse/border
                  [thick-ellipse (->* (nonneg-real? nonneg-real?
                                       (real-in 0 255)
                                       color/c)
                                      (#:fill-color (or/c #f color/c))
                                      pict?)]
                  [thick-filled-rounded-rectangle
                   (->* (nonneg-real? nonneg-real?)
                        (real?
                         #:color color/c
                         #:style brush-style/c
                         #:angle real?
                         #:border-width (real-in 0 255)
                         #:border-color (or/c #f color/c)
                         #:border-style pen-style/c)
                        pict?)]
                  [mk-center (real? real? pict? pict? . -> . (values real? real?))]
                  [compose-find (-> (-> pict? pict-path? (values real? real?))
                                    (-> pict? pict-path? (values real? real?))
                                    pict?
                                    (-> pict? pict-path? (values real? real?)))]
                  [chop-at (->i ([min real?]
                                 [max (min) (>/c min)]
                                 [i real?])
                                [result (min max) (real-in min max)])]
                  [lerp (real? real? (real-in 0 1) . -> . real?)]
                  [chopped-interval-scale ((real-in 0 1) (real-in 0 1) . -> . ((real-in 0 1) . -> . (real-in 0 1)))]
                  [annulus
                   (->i ([w nonneg-real?]
                         [h nonneg-real?]
                         [rw (w h) (and/c nonneg-real? (within-width-and-height w h))])
                        [#:color [color (or/c #f color/c)]
                         #:style [style brush-style/c]
                         #:border-width [border-width (real-in 0 255)]
                         #:border-color [border-color (or/c #f color/c)]
                         #:border-style [border-style pen-style/c]]
                        [result pict?])]
                  [arc
                   (->* (nonneg-real? nonneg-real?)
                        [real? real? any/c
                         #:color (or/c #f color/c)
                         #:style brush-style/c
                         #:border-width (real-in 0 255)
                         #:border-color (or/c #f color/c)
                         #:border-style pen-style/c]
                        pict?)]
                  [filled-rounded-rectangle-frame
                   (->* (pict?)
                        [#:color color/c
                         #:scale nonneg-real?
                         #:x-scale nonneg-real?
                         #:y-scale nonneg-real?
                         #:corner-radius real?
                         #:angle real?
                         #:border-width (real-in 0 255)
                         #:border-color color/c
                         #:border-style pen-style/c]
                        pict?)]
                  [filled-flash-frame
                   (->* (pict?)
                        [#:scale nonneg-real?
                         #:color (or/c color/c #f)
                         #:outline (or/c color/c #f)
                         #:n-points exact-positive-integer?
                         #:spike-fraction (real-in 0 1)
                         #:rotation real?]
                        pict?)]
                  [filled-polygon
                   (->* ((listof (list/c real? real?)))
                        [#:outline (or/c #f color/c)
                                   #:outline-style pen-style/c
                                   #:outline-width (real-in 0 255)
                                   #:color (or/c #f color/c)
                                   #:fill-style brush-style/c
                                   #:scale-x real?
                                   #:scale-y real?]
                        pict?)]
                  [filled-regular-polygon
                   (->* (exact-positive-integer? nonneg-real?)
                        [#:outline (or/c #f color/c)
                         #:outline-style pen-style/c
                         #:outline-width (real-in 0 255)
                         #:color (or/c #f color/c)
                         #:fill-style brush-style/c
                         #:scale-x real?
                         #:scale-y real?]
                        pict?)]
                  [slide-and-compose (->* (pict? (vectorof pict?) pict?)
                                          [(pict? (real-in 0 1) . -> . pict?)]
                                          ((real-in 0 1) . -> . pict?))]
                  [play-n-at (exact-nonnegative-integer?
                              exact-nonnegative-integer?
                              (nondecreasing-listof exact-nonnegative-integer?)
                              (listof pict?)
                              boolean?
                              . -> . (listof pict?))]
                  [progressive-table
                   (->* (exact-nonnegative-integer?       ;; stage
                         (nondecreasing-listof exact-nonnegative-integer?) ;; stages
                         exact-nonnegative-integer? ;; ncols
                         (listof pict?)             ;; picts
                         (list*of (->* () #:rest (listof pict?) pict?)) ;; col-aligns
                         (list*of (->* () #:rest (listof pict?) pict?)) ;; row-aligns
                         (list*of real?) ;; col-seps
                         (list*of real?) ;; row-seps
                         )
                        [#:ghost? boolean?]
                        pict?)])

;; brush/pen not parameters, unfortunately.
;; Imperative save-restore to the "rescue."
(begin-for-syntax
 (define-syntax-class (gsr dc-stx)
   #:attributes (g s do)
   (pattern [g:id s:id (~optional (~seq (~or (~and #:unless (~bind [guarder #'unless]))
                                             (~and #:when (~bind [guarder #'when])))
                                        guard:expr))
                  r:expr ...]
            #:with do (cond
                       [(attribute guard) #`(guarder guard (send #,dc-stx s r ...))]
                       [else #`(send #,dc-stx s r ...)]))))
(define-simple-macro (with-save dc (~var p (gsr #'dc)) body ...)
  (let* ([dcv dc]
         [v (send dcv p.g)])
    p.do
    body ...
    (send dcv p.s v)))
(define-syntax (with-save* stx)
  (syntax-parse stx
    [(_ dc () body ...) (syntax/loc stx (let () body ...))]
    [(_ dc (~and (give gives ...)
                 ((~var p (gsr #'dcv)) (~var ps (gsr #'dcv)) ...))
         body ...)
     (syntax/loc stx (let ([dcv dc])
                       (with-save dcv give
                                  (with-save* dcv (gives ...) body ...))))]))

;; ellipse/border does the wrong thing.
(define (thick-ellipse ew eh thickness color #:fill-color [fill-color #f])
  (define-values (fill-color* style)
    (if fill-color
        (values fill-color 'solid)
        (values "white" 'transparent)))
  (dc (λ (dc dx dy)
         (with-save* dc ([get-brush set-brush (send the-brush-list find-or-create-brush fill-color* style)]
                         [get-pen set-pen color thickness 'solid])
           (send dc draw-ellipse dx dy ew eh)))
      ew eh))

(define (annulus w h rw
                 #:color [color #f]
                 #:style [style 'solid]
                 #:border-color [border-color #f]
                 #:border-width [border-width 1]
                 #:border-style [border-style 'solid])
  (dc (lambda (dc x y)
        (define p (new dc-path%))
        (define w2 (/ w 2))
        (define h2 (/ h 2))
        (define 2rw (* 2 rw))
        
        (send p move-to (- w rw) h2)
        (send p arc rw rw (- w 2rw) (- h 2rw) 0 (* 2 pi))
        (send p move-to w h2)
        (send p arc 0 0 w h 0 (* 2 pi))
        (send p translate x y)
        (send p close)
        
        (define brush (if color
                          (send the-brush-list find-or-create-brush color style)
                          (send the-brush-list find-or-create-brush "white" 'transparent)))
        (define pen (if border-color
                        (send the-pen-list find-or-create-pen border-color border-width border-style)
                        (send the-pen-list find-or-create-pen "black" 1 'transparent)))
        (with-save* dc ([get-brush set-brush brush]
                        [get-pen set-pen pen])
          (send dc draw-path p)))
      w h))

(define (arc w h [startθ 0] [endθ pi] [counter-clockwise? #t]
             #:color [color #f]
             #:style [style 'solid]
             #:border-color [border-color #f]
             #:border-width [border-width 1]
             #:border-style [border-style 'solid])
  (dc (lambda (dc x y)
        (define p (new dc-path%))
        (send p arc 0 0 w h startθ endθ counter-clockwise?)
        (send p line-to (/ w 2) (/ h 2))
        (send p translate x y)
        (send p close)
        
        (define brush (if color
                          (send the-brush-list find-or-create-brush color style)
                          (send the-brush-list find-or-create-brush "white" 'transparent)))
        (define pen (if border-color
                        (send the-pen-list find-or-create-pen border-color border-width border-style)
                        (send the-pen-list find-or-create-pen "black" 1 'transparent)))
        (with-save* dc ([get-brush set-brush brush]
                        [get-pen set-pen pen])
                    (send dc draw-path p)))
      w h))

(define (mk-center x y base top)
  (values (+ x (/ (pict-width base) 2)
             (- (/ (pict-width top) 2)))
          (+ y (/ (pict-height base) 2) (- (/ (pict-height top) 2)))))

(define (pin-under-all base tag pict)
  (define pw (pict-width pict))
  (define ph (pict-height pict))
  (define paths (find-tag* base tag))
  (for/fold ([pict* base]) ([path (in-set (list->set paths))]
                            #:unless (and (pair? path) (is-ghost? (car path))))
    (define-values (dx dy) (lt-find pict* path))
    (define p (first path))
    (define-values (dx* dy*) (mk-center dx dy p pict))
    (pin-under pict* dx* dy* pict)))

(define (pin-center pinner base dx dy pict)
  (pinner base
            (- dx (/ (pict-width pict) 2))
            (- dy (/ (pict-height pict) 2))
            pict))
;; Pin the center of pict at dx dy offset from base's top left corner.
(define (pin-over-center base dx dy pict)
  (pin-center pin-over base dx dy pict))
(define (pin-under-center base dx dy pict)
  (pin-center pin-under base dx dy pict))

(define (pin-over-vcenter base dx dy pict #:x-translate [x-translate 0])
  (define-values (x y)
    (if (procedure? dy)
        (dy base dx)
        (values dx dy)))
  (pin-over base
            (+ x x-translate)
            (- y (/ (pict-height pict) 2))
            pict))

;; Linearly interpolate from start to end
(define (lerp start end n) (+ (* n end) (* start (- 1 n))))

(define (pin-over-hcenter base dx dy pict #:y-translate [y-translate 0])
  (define-values (x y)
    (if (procedure? dy)
        (dy base dx)
        (values dx dy)))
  (pin-over base
            (- x (/ (pict-width pict) 2))
            (+ y y-translate)
            pict))

(define (both f) (f #f) (f #t))

(define (is-ghost? pict)
  (match (pict-draw pict)
    [`(picture ,w ,h) #t] [_ #f]))

(define (chop-at min max i)
  (cond [(< i min) min]
        [(> i max) max]
        [else i]))
;; unit-interval ∈ [0, 1].
;; When unit-interval ∈ [min, max], uniformly scale from 0 to 1 as min approaches max.
;; When unit-interval < min. 0
;; When unit-interval > max. 1
(define (chopped-interval-scale min max)
  (define 1/distance (/ 1 (- max min)))
  (λ (unit-interval)
     (cond [(< unit-interval min) 0]
           [(> unit-interval max) 1]
           [else (chop-at 0 1 (* 1/distance (- unit-interval min)))])))

;; All picts in pict-vec must be in base, as well as from-pic.
;; comp : pict? (real-in 0 1) → pict?
;; Animation sliding all picts in pict-vec to their places in base,
;; starting from from-pic. While sliding, the pic can be further transformed by comp.
(define (slide-and-compose base pict-vec from-pic [comp (λ (p n) p)])
  (define num (vector-length pict-vec))
  (λ (n)
     (for/fold ([p* base]) ([ipict (in-vector pict-vec)]
                            [i (in-naturals)])
       (define interval (chopped-interval-scale (/ i num) (min 1 (/ (add1 i) (max 1 (- num 2))))))
       (define windowed (interval n))
       (slide-pict p* (comp ipict windowed) from-pic ipict (fast-start windowed)))))

(define (colorize-if b p c) (if b (colorize p c) p))

(define (thick-filled-rounded-rectangle w h [corner-radius -0.25]
                                        #:color [color "black"]
                                        #:style [style 'solid]
                                        #:angle [angle 0]
                                        #:border-width [border-width 1]
                                        #:border-color [border-color #f]
                                        #:border-style [border-style 'solid])
    (let ([dc-path (new dc-path%)])
      (send dc-path rounded-rectangle 0 0 w h corner-radius)
      (send dc-path rotate angle)
      (let-values ([(x y w h) (send dc-path get-bounding-box)])
        (dc (λ (dc dx dy) 
              (with-save* dc ([get-brush set-brush
                                         (send the-brush-list find-or-create-brush color style)]
                              [get-pen set-pen #:when border-color
                                       (send the-pen-list find-or-create-pen
                                             border-color 
                                             border-width border-style)])
                (send dc draw-path dc-path (- dx x) (- dy y))))
            w h))))

(define (filled-rounded-rectangle-frame pict
                                        #:color [color "white"]
                                        #:scale [scale 1]
                                        #:x-scale [x-scale 1]
                                        #:y-scale [y-scale 1]
                                        #:corner-radius [corner-radius -0.25]
                                        #:angle [angle 0]
                                        #:border-width [border-width 1]
                                        #:border-color [border-color "black"]
                                        #:border-style [border-style 'solid])
  (define dx (* x-scale scale (pict-width pict)))
  (define dy (* y-scale scale (pict-height pict)))
  (define rect
    (thick-filled-rounded-rectangle dx dy
                                    corner-radius
                                    #:color color
                                    #:angle angle
                                    #:border-width border-width
                                    #:border-color border-color
                                    #:border-style border-style))
  (cc-superimpose rect pict))

(define (filled-flash-frame pict
                            #:scale [scale 3/2]
                            #:color [color #f]
                            #:outline [outline #f]
                            #:n-points [n-points 10]
                            #:spike-fraction [spike-fraction 0.25]
                            #:rotation [rotation 0])
  (define flash
    (filled-flash (* scale (pict-width pict)) (* scale (pict-height pict))
                  n-points spike-fraction rotation))

  (cc-superimpose
   (if outline
       (colorize (outline-flash (* scale (pict-width pict)) (* scale (pict-height pict))
                                n-points spike-fraction rotation)
                 outline)
       (blank))
   (colorize-if color flash color)
   pict))

(define no-brush
    (send the-brush-list find-or-create-brush "white" 'transparent))
(define no-pen
  (send the-pen-list find-or-create-pen "white" 0 'transparent))
(define (filled-polygon points
                        #:outline [outline #f]
                        #:outline-style [outline-style 'solid]
                        #:outline-width [width 1]
                        #:color [color "black"]
                        #:fill-style [fill-style 'solid]
                        #:scale-x [scale-x 1]
                        #:scale-y [scale-y 1])
  (match points
    ['() (blank)]
    [(cons (list x0 y0) points)
     (define p (new dc-path%))
     (define fst (car points))
     (send p move-to x0 y0)
     (let loop ([points points])
       (match points
         ['() (void)]
         [(cons (list x y) rest) (send p line-to x y) (loop rest)]))
     (send p close)
     (send p scale scale-x scale-y)
     (define-values (bx by bw bh) (send p get-bounding-box))
     (send p translate (/ width 2) (/ width 2))
     (dc (λ (dc x y)
            (with-save* dc ([get-brush set-brush
                                       (if color
                                           (send the-brush-list find-or-create-brush color fill-style)
                                           no-brush)]
                            [get-pen set-pen (if outline
                                                 (send the-pen-list find-or-create-pen outline width outline-style)
                                                 no-pen)])
              (send dc draw-path p x y)))
         (+ bw width) (+ bh width))]))

(define (filled-regular-polygon side-length side-count
                                #:outline [outline #f]
                                #:outline-style [outline-style 'solid]
                                #:outline-width [width 1]
                                #:color [color "black"]
                                #:fill-style [fill-style 'solid]
                                #:scale-x [scale-x 1]
                                #:scale-y [scale-y 1])
  (define reg-points (regular-polygon-points side-length side-count))
  (define-values (l t)
    (for/fold ([l +inf.0] [t +inf.0]) ([p (in-list reg-points)])
      (values (min l (first p)) (min t (second p)))))
  (define points (for/list ([p (in-list reg-points)]) (list (- (first p) l) (- (second p) t))))
  (filled-polygon points
                  #:outline outline
                  #:outline-style outline-style
                  #:outline-width width
                  #:color color
                  #:fill-style fill-style
                  #:scale-x scale-x
                  #:scale-y scale-y))

;; XXX: Yanked from 2htdp/image
;; regular-polygon-points : number number -> (listof point)
(define (regular-polygon-points side-length side-count)
  (let loop ([p 0+0i]
             [i 0])
    (cond
      [(= i side-count) '()]
      [else (cons (list (real-part p) (imag-part p)) 
                  (loop (+ p (make-polar side-length (* 2 pi (/ i side-count))))
                        (+ i 1)))])))

;; n stage : natural
;; stages: monotonically non-decreasing list of naturals
;; lst: list
(define (play-n-at n stage stages lst ghost?)
  (let loop ([stages stages] [lst lst])
    (cond [(empty? stages)
           (if ghost?
               (map ghost lst)
               '())]
          [(<= (first stages) stage)
           (define-values (to-show the-rest) (split-at lst n))
           (append to-show (loop (rest stages) the-rest))]
          [else (loop (rest stages) lst)])))

;; Given the current stage and the "rollout" stages, show the rows
;; up to the current stage.
;; there should be as many stages as there are rows.
(define (progressive-table stage stages ncols picts col-aligns row-aligns col-seps row-seps #:ghost? [ghost? #t])
  (cond [(or (zero? ncols) (empty? stages) (empty? picts)) (blank)]
        [else
         (define rows (/ (length picts) (length stages)))
         (define prog-picts (play-n-at rows stage stages picts ghost?))
         (cond [(empty? prog-picts) (blank)]
               [else (table ncols prog-picts col-aligns row-aligns col-seps row-seps)])]))

(define (pin-at-tag pin base finder tag pict-fn)
  (define path (find-tag base tag))
  (pin base (first path) finder (pict-fn (first path))))

(define (pin-under-tag base finder tag pict-fn)
  (pin-at-tag pin-under base finder tag pict-fn))
(define (pin-over-tag base finder tag pict-fn)
  (pin-at-tag pin-over base finder tag pict-fn))

;; like cc-find, only offset from 
(define (compose-find find other-find wrt)
  (λ (pict pict-path)
     (define-values (x y) (find pict pict-path))
     (define-values (wx wy) (other-find wrt (list wrt)))
     (values (- x wx) (- y wy))))