#lang racket/gui

(provide smoothscroll-canvas%)

(define smoothscroll-canvas% (class canvas%
                               (init-field virtual-width virtual-height
                                           [fit-width? #f]
                                           [fit-height? #f]
                                           [max-scroll-amount 20]
                                           [scrolling-window-ms 100])
                               (super-new)
                               (inherit get-dc scroll set-scroll-pos get-client-size)

                               (field [virtual-x-pos 0]
                                      [virtual-y-pos 0]
                                      [last-scroll-time 0])

                               (define/public (set-virtual-size! width height)
                                 (set! virtual-width width)
                                 (set! virtual-height height))


                               (define/override (on-paint)
                                                (send (get-dc) clear)
                                                (send (get-dc) draw-text "hello world" (- 100 virtual-x-pos) (- 100 virtual-y-pos) ))

                               (define/override (get-virtual-size)
                                                (values virtual-width virtual-height))
                               (define/override (get-view-start)
                                                (values virtual-x-pos virtual-y-pos))

                               (define/override (on-size canvas-width canvas-height)
                                                (when fit-width? (set! virtual-width canvas-width))
                                                (when fit-height? (set! virtual-height canvas-height))

                                                (when (and
                                                        (< canvas-width virtual-width)
                                                        (> (+ virtual-x-pos canvas-width)
                                                           virtual-width))
                                                  (set! virtual-x-pos (- virtual-width canvas-width)))

                                                (when (and
                                                        (< canvas-height virtual-height)
                                                        (> (+ virtual-y-pos canvas-height)
                                                           virtual-height))
                                                  (set! virtual-y-pos (- virtual-height canvas-height))))

                               (define/override (on-char key-event)
                                                (let* ([code (send key-event get-key-code)]
                                                       [new-time (current-milliseconds)]
                                                       [dif-time (- new-time last-scroll-time)]

                                                       [step (if (>= dif-time scrolling-window-ms)
                                                               1
                                                               (* max-scroll-amount
                                                                  (/ (- scrolling-window-ms dif-time)
                                                                     scrolling-window-ms)))])
                                                  (define-values (client-width client-height) (get-client-size))

                                                  (case code
                                                    ['wheel-down  (set! virtual-y-pos (min   (+ virtual-y-pos step)
                                                                                             (max 0 (- virtual-height client-height))))]
                                                    ['wheel-up    (set! virtual-y-pos (max 0 (- virtual-y-pos step)))]

                                                    ['wheel-left  (set! virtual-x-pos (max 0 (- virtual-x-pos step)))]
                                                    ['wheel-right (set! virtual-x-pos (min   (+ virtual-x-pos step)
                                                                                             (max 0 (- virtual-width client-width))))]

                                                    [else (super on-char key-event)])

                                                  (set! last-scroll-time new-time)
                                                  (on-paint)))))

(module* main #f
  (define testframe (new frame% [label "Scroll Test"] [width 400] [height 400]))

  (define test-canvas (new smoothscroll-canvas%
                           [parent testframe]
                           ;[style '(hscroll vscroll)]
                           [virtual-width  10]
                           [virtual-height 10]
                           ;[fit-width? #t]
                           ;[fit-height? #t]

                           [paint-callback (λ (canvas dc)
                                              (let-values ([(virtual-x-pos virtual-y-pos) (send canvas get-view-start)])
                                                (send dc clear)
                                                (send dc draw-text "hello world" (- 100 virtual-x-pos) (- 100 virtual-y-pos))))]))

  (send test-canvas set-virtual-size! 800 800)

  (send testframe show #t))