sprite.rkt

#lang racket/gui

(require (for-syntax racket/base syntax/parse))

(define-match-expander obj
  (λ (stx)
    (syntax-parse stx
      [(_ cls%:expr)
       #'(obj cls% _)]
      [(_ cls%:expr binding:id)
       #'(? (λ (thing) (is-a? thing cls%)) binding)]
      [(_ cls%:expr binding:id ([method:id value:expr] ...))
       #'(and (obj cls% binding)
              (app (λ (o) (send o method)) value) ...)]
      [(_ cls%:expr ([method:id value:expr] ...))
       #'(obj cls% _ ([method value] ...))])))


(provide (all-defined-out))

(define sprite%
  (class object%
    (super-new)
    (init-field bitmap [event-callback void])
    (define scenes empty)
    (define/public (get-bitmap)
      bitmap)
    (define/public (set-bitmap new-bitmap)
      (set! bitmap new-bitmap))
    (define/public (get-width)
      (send bitmap get-width))
    (define/public (get-height)
      (send bitmap get-height))
    (define/public (on-event canvas instance evt)
      (event-callback canvas instance evt))
    (define/public (clone)
      (define bm (make-object bitmap% (get-width) (get-height)))
      (define dc (send bm make-dc))
      (send dc draw-bitmap bitmap 0 0)
      (new sprite%
           [bitmap bm]
           [event-callback event-callback]))))

(struct SpriteInstance [identifier sprite x y z-order] #:transparent)

(define scene%
  (class object%
    (super-new)
    (define sprites (make-hasheq))
    (define (max-z-order)
      (for/fold ([acc 999])
                ([sprite (in-hash-values sprites)])
        (max acc (SpriteInstance-z-order sprite))))
    (define (min-z-order)
      (for/fold ([acc -999])
                ([sprite (in-hash-values sprites)])
        (min acc (SpriteInstance-z-order sprite))))
    (define/public (add! sprite x y #:z-order [z-order #f])
      (unless z-order
        (set! z-order (add1 (max-z-order))))
      (define identifier (gensym "sprite-instance-"))
      (hash-set! sprites identifier
                 (SpriteInstance identifier sprite x y z-order))
      identifier)
    (define/public (remove! identifier)
      (hash-remove! sprites identifier))
    (define/public (clear! identifier)
      (set! sprites (make-hasheq)))
    (define/public (get-sprites-in-drawing-order)
      (sort (hash-values sprites) <
            #:key SpriteInstance-z-order))
    (define/public (to-front! identifier)
      (hash-update! sprites identifier (λ (instance) (struct-copy SpriteInstance instance [z-order (add1 (max-z-order))]))))))

(define canvas+scene%
  (class canvas%
    (super-new)
    (init-field [scene (new scene%)])
    (define/public (get-scene)
      scene)
    (define/override (on-paint)
      (define dc (send this get-dc))
      (send* dc
        (clear)
        (set-smoothing 'smoothed)
        (set-scale 4 4))
      (for ([instance (send scene get-sprites-in-drawing-order)])
        (match-define
          (struct* SpriteInstance ([sprite sprite] [x x] [y y]))
          instance)
        (send dc draw-bitmap (send sprite get-bitmap) x y)))
    (define/override (on-event evt)
      (match evt
        [(obj mouse-event% ([get-x x] [get-y y]))
         (define-values (scale-x scale-y) (send (send this get-dc) get-scale))
         (for/first ([instance (reverse (send scene get-sprites-in-drawing-order))]
                     #:when (match instance
                              [(struct* SpriteInstance
                                        ([x sx]
                                         [y sy]
                                         [sprite (obj sprite%
                                                      ([get-width width]
                                                       [get-height height]))]))
                               (and (<= (* scale-x sx) x (* scale-x (+ sx width)))
                                    (<= (* scale-y sy) y (* scale-y (+ sy height))))]
                              [_ #f]))
           (send (SpriteInstance-sprite instance) on-event
                 this instance evt))]
        [unhandled
         (printf "Unhandled event ~a\n" evt)]))))

(define (main)
  (define f (new frame% [label "Scene demo"]))
  (define scene (new scene%))
  (define circle-bitmap (let ([bm (make-object bitmap% 100 100)])
                           (send* (send bm make-dc)
                             (set-pen "black" 2 'solid)
                             (set-brush "white" 'solid)
                             (draw-rectangle 0 0 100 100))
                           bm))
  (define clicked-choices
    (for/list ([color '(green yellow red blue pink purple teal)])
      (let* ([bm (make-object bitmap% 100 100)])
        (send* (send bm make-dc)
          (set-pen "black" 2 'solid)
          (set-brush (~a color) 'solid)
          (draw-rectangle 0 0 100 100))
        bm)))
  (define clicked-timeouts (make-hasheq))
  (define circle (new sprite%
                      [bitmap circle-bitmap]
                      [event-callback
                       (λ (canvas instance evt)
                         (match evt
                           [(obj mouse-event% ([get-event-type 'left-down]))
                            (match-define (struct* SpriteInstance ([sprite spr]
                                                                   [identifier id]))
                              instance)
                            (send (send canvas get-scene) to-front! id)
                            (match (hash-ref clicked-timeouts id #f)
                              [#f (void)]
                              [th (kill-thread th)
                                  (hash-remove! clicked-timeouts id)])
                            (printf "Sprite click ~a - ~a\n" instance evt)

                            (send spr set-bitmap (car (shuffle clicked-choices)))
                            (send canvas on-paint)
                            (hash-set! clicked-timeouts id (thread
                                                            (thunk
                                                             (sleep 2)
                                                             (send spr set-bitmap circle-bitmap)
                                                             (send canvas on-paint)
                                                             (hash-remove! clicked-timeouts id))))]
                           [_ (void)]))]))
  (send* scene
    (add! circle 0 0)
    (add! (send circle clone) 20 20)
    (add! (send circle clone) 50 50)
    (add! (send circle clone) 200 200))
  (define canvas (new canvas+scene% [parent f] [scene scene]))
  (send f show #t))

(module+ main
  (main))