Spreadsheet editor in Racket

(require racket/gui
         racket/draw
         data/gvector)
(require (planet williams/table-panel:1:2/table-panel))

;; Helper function
(define (find-max list get-value)
  (for/fold ((max-value 0)) ((x list))
    (max (get-value x) max-value)))

;; Global constants describing the table
(define n-rows 10000)
(define n-columns 1000)
(define rownum-column-width 70)

;; Accessing table cells (stub)
(define cell-contents-hash (make-hash))

(define (get-cell-contents row column)
  (hash-ref cell-contents-hash (list row column) ""))

(define (set-cell-contents! row column contents)
  (hash-set! cell-contents-hash (list row column) contents))

;; Column header (stub)
(define (get-column-label i)
  (number->string (+ 1 i)))

;; Number of row and column buttons currently visible
(define n-row-buttons 0)
(define n-column-buttons 0)
(define starting-row 0)
(define starting-column 0)

;; All visible row buttons
(define row-buttons (gvector))

;; All column buttons (visible or not)
(define all-column-buttons (make-vector n-columns))

;; Helper functions for scrolling
(define (calculate-starting-column pivot width)
  (define n-buttons 0)
  (define column pivot)
  (define total-length 0)
  (let loop ((i pivot)
             (length 0))
    (cond
      ((>= i (vector-length all-column-buttons))
       (let loop1 ((i pivot) (length length))
         (cond
           ((zero? i) 0)
           ((<= (+ length (send (vector-ref all-column-buttons (- i 1)) min-width)) width)
            (loop1 (- i 1) (+ length (send (vector-ref all-column-buttons (- i 1)) min-width))))
           (else i))))
      ((> length width) pivot)
      (else
       (loop (+ i 1) (+ length (send (vector-ref all-column-buttons i) min-width)))))))

(define (calculate-starting-row pivot height)
  (define button-height (send (gvector-ref row-buttons 0) get-height))
  (define nbuttons-visible (floor (/ height button-height)))
  (cond
    ((< (+ pivot nbuttons-visible) n-rows) pivot)
    ((>= nbuttons-visible n-rows) 0)
    (else (- n-rows nbuttons-visible))))

;; Helper functions for table cell editing
(define (detect-column-by-x x)
  (define-values (col _)
    (for/fold ((result starting-column)
               (length 0))
      ((button (send hpanel-top get-children)))
      #:break (<= x (+ length (send button min-width)))
      (values (+ result 1)
              (+ length (send button min-width)))))
  (if (< col n-columns) col #f))

(define (detect-row-by-y y)
  (define rownum
    (+ starting-row (floor (/ y (send (gvector-ref row-buttons 0) get-height)))))
  (if (< rownum n-rows) rownum #f))

;; Panel with column buttons
(define my-horizontal-panel%
  (class horizontal-panel%
    (super-new)
    (define/override (container-size info)
      (values 0 (find-max info second)))
    (define/override (on-size w h)
      (define total-length 0)
      (set! n-column-buttons 0)
      (define flag #f)
      (send this begin-container-sequence)
      ;; Delete buttons that are completely out of sight
      (for ((child (send this get-children))
            (i (in-naturals starting-column)))
        (set! total-length (+ total-length (send child min-width)))
        (cond
          ((> total-length w)
           (cond
             (flag
              (send this delete-child child))
             (else
              (set! n-column-buttons (+ 1 n-column-buttons))
              (set! flag #t))))
          (else
           (set! n-column-buttons (+ 1 n-column-buttons)))))
      ;; Add buttons till there is place on the panel
      (let loop ()
        (when (and (< total-length w)
                   (< (+ starting-column n-column-buttons) (vector-length all-column-buttons)))
          (define button (vector-ref all-column-buttons (+ starting-column n-column-buttons)))
          (send this add-child button)
          (set! n-column-buttons (+ 1 n-column-buttons))
          (set! total-length (+ total-length (send button min-width)))
          (loop)))
      (send this end-container-sequence))))

;; Panel with row buttons
(define my-vertical-panel%
  (class vertical-panel%
    (super-new)
    (define/override (container-size info)
      (values 0 0))
    (define/override (on-size w h)
      (define total-length 0)
      (set! n-row-buttons 0)
      (send this begin-container-sequence)
      ;; Delete buttons that are completely out of sight
      (for ((child (send this get-children))
            (i (in-naturals)))
        (set! total-length (+ total-length (send child get-height)))
        (cond
          ((> total-length h)
           (send this delete-child child))
          (else
           ;; ... and relabel buttons that are visible
           (send child set-label (number->string (+ 1 n-row-buttons starting-row)))
           (set! n-row-buttons (+ 1 n-row-buttons))
           )))
      ;; Add buttons till there is place on the panel
      (let loop ()
        (when (and (< total-length h)
                   (< (+ n-row-buttons starting-row) n-rows))
          (define button (void))
          (cond
            ((< n-row-buttons (gvector-count row-buttons))
             ;; Relabel and reuse a previously added and deleted button
             (set! button (gvector-ref row-buttons n-row-buttons))
             (send button set-label (number->string (+ 1 n-row-buttons starting-row)))
             (send this add-child button))
            (else
             ;; Add a new button
             (set! button (new button%
                               (parent this)
                               (stretchable-width #t)
                               (horiz-margin 0)
                               (vert-margin 0)
                               (label (number->string (+ 1 n-row-buttons starting-row)))))
             (gvector-add! row-buttons button)))
          (set! n-row-buttons (+ 1 n-row-buttons))
          (set! total-length (+ total-length (send button get-height)))
          (loop)))
      (send this end-container-sequence)
      )))

;; Transient text snip to edit cell contents
(define text-snip (void))
(define text-snip-row (void))
(define text-snip-column (void))

(define (done-with-text-snip save-contents?)
  (unless (void? text-snip)
    (when save-contents?
      (set-cell-contents! text-snip-row text-snip-column (send (send text-snip get-editor) get-text)))
    (define ts text-snip)
    ;; void the text-snip to prevent another (done-with-text-snip) from on-focus
    (set! text-snip (void))
    (send ts release-from-owner)
    (send editor-canvas refresh)))

;; Specialized text% for editing the cell contents
(define my-text%
  (class text%
    (super-new)
    (define/override (on-focus on?)
      (unless on?
        (done-with-text-snip #t))
      (super on-focus on?))
    (define/override (on-char event)
      (define key-code (send event get-key-code))
      (when (equal? key-code 'escape)
        (done-with-text-snip #f))
      (when (equal? key-code #\return)
        (done-with-text-snip #t))
      (super on-char event))))

(define brown-delta-fg
  (send (make-object style-delta%) set-delta-foreground (make-object color% "brown")))
(define yellow-delta-bg
  (send (make-object style-delta%) set-delta-background (make-object color% "yellow")))

;; Specialized pasteboard% to place the text snip on
(define my-pasteboard%
  (class pasteboard%
    (super-new)
    (define/override (on-default-event event)
      (define type (send event get-event-type))
      (cond
        ((equal? type 'left-down)
         (unless (void? text-snip)
           (done-with-text-snip #t))
         (define x (send event get-x))
         (define y (send event get-y))
         (set! text-snip-column (detect-column-by-x x))
         (define column-height (send (gvector-ref row-buttons 0) get-height))
         (define column-width (send (vector-ref all-column-buttons text-snip-column) get-width))
         (define column-x (send (vector-ref all-column-buttons text-snip-column) get-x))
         (set! text-snip-row (detect-row-by-y y))
         (define column-y (send (gvector-ref row-buttons (- text-snip-row starting-row)) get-y))
         (define text-obj (new my-text%))
         (send text-obj insert (get-cell-contents text-snip-row text-snip-column) 0)
         (send text-obj extend-position 0)
         (set! text-snip (new editor-snip%
                         (editor text-obj)
                         (left-margin 0) (right-margin 0) (top-margin 0) (bottom-margin 0)
                         (with-border? #t)
                         (min-width column-width)
                         (max-width column-width)
                         (min-height column-height)
                         (max-height column-height)))
         (send this insert text-snip column-x column-y)
         (send text-obj change-style yellow-delta-bg)
         (send this change-style brown-delta-fg text-snip)
         (send this set-caret-owner text-snip)
         ))
      (void))))

;; Specialized canvas to draw the grid lines and cells' contents
(define my-editor-canvas%
  (class editor-canvas%
    (super-new)
    (define/override (on-paint)
      (super on-paint)
      (define dc (send this get-dc))
      (define-values (width height) (send dc get-size))
      (define border-x 0)
      (define border-y 0)
      (when (positive? n-column-buttons)
        (define border-column-button
          (vector-ref all-column-buttons
                      (+ starting-column n-column-buttons -1)))
        (set! border-x (+ (send border-column-button get-x)
                            (send border-column-button get-width))))
      (when (positive? n-row-buttons)
        (define border-row-button
          (gvector-ref row-buttons
                      (- n-row-buttons 1)))
        (set! border-y (+ (send border-row-button get-y)
                          (send border-row-button get-height))))
      (for ((btn (send hpanel-top get-children)))
        (send dc draw-line
              (- (send btn get-x) 1) 0
              (- (send btn get-x) 1) (- border-y 1)))
      (send dc draw-line
              (- border-x 1) 0
              (- border-x 1) (- border-y 1))
      (for ((btn row-buttons))
        (send dc draw-line
              0 (- (send btn get-y) 1)
              (- border-x 1) (- (send btn get-y) 1)))
      (send dc draw-line
              0 (- border-y 1)
              (- border-x 1) (- border-y 1))
      (for ((col-btn (send hpanel-top get-children))
            (column (in-naturals starting-column)))
        (for ((row-btn row-buttons)
              (row (in-naturals starting-row)))
          (send dc set-clipping-rect (send col-btn get-x) (send row-btn get-y)
                (send col-btn get-width) (send row-btn get-height))
          (send dc draw-text (get-cell-contents row column) (send col-btn get-x) (send row-btn get-y) )
          (send dc set-clipping-region #f)))
      )))

;; Main window
(define frame (new frame% (label "Table editor")))

;; Main window 3x3 layout
(define table-panel
  (new table-panel%
    (parent frame)
    (alignment '(center center))
    (spacing 0)
    (stretchable-width #t)
    (stretchable-height #t)
    (horiz-margin 0)
    (vert-margin 0)
    (dimensions '(3 3))))

;; Top-left corner
(new pane%
     (parent table-panel)
     (horiz-margin 0)
     (vert-margin 0)
     (stretchable-width #f)
     (stretchable-height #f))

(define hpanel-top
    (new my-horizontal-panel%
         (parent table-panel)
         (border 0)
         (stretchable-width #t)
         (stretchable-height #f)))

(for ((i (in-range n-columns)))
  (vector-set!
   all-column-buttons i
   (new button%
        (parent hpanel-top)
        (stretchable-width #f)
        (horiz-margin 0)
        (vert-margin 0)
        (min-width 80)
        (style '(deleted))
        (label (get-column-label i)))))

;; Top-right corner
(new pane%
     (parent table-panel)
     (horiz-margin 0)
     (vert-margin 0)
     (stretchable-width #f)
     (stretchable-height #f))

(define vpanel-left
  (new my-vertical-panel%
       (parent table-panel)
       (border 0)
       (stretchable-width #f)
       (stretchable-height #t)
       (min-width rownum-column-width)))


;; Canvas (middle cell in the 3x3 layout)
(define editor-canvas
  (new my-editor-canvas%
       (editor (new my-pasteboard%))
       (vertical-inset 0)
       (horizontal-inset 0)
       (parent table-panel)
       (style '(no-border no-hscroll no-vscroll))))

(define vslider
  (new slider%
       (parent table-panel)
       (stretchable-width #f)
       (stretchable-height #t)
       (label "")
       (style '(vertical plain))
       (min-value 1)
       (max-value n-rows)
       (callback
        (lambda (self event)
          (define new-starting-row
            (calculate-starting-row
                                  (- (send self get-value) 1)
                                  (send vpanel-left get-height)))
          (unless (equal? starting-row new-starting-row)
            (set! starting-row new-starting-row)
            (send vpanel-left on-size
                  (send vpanel-left get-width)
                  (send vpanel-left get-height))
            (send editor-canvas refresh))))))

;; Bottom left corner
(new pane%
     (parent table-panel)
     (stretchable-width #f)
     (stretchable-height #f)
     (horiz-margin 0)
     (vert-margin 0)
     (min-width rownum-column-width))

(define hslider
  (new slider%
       (parent table-panel)
       (label "")
       (style '(horizontal plain))
       (min-value 1)
       (max-value n-columns)
       (stretchable-height #f)
       (callback
        (lambda (self event)
          (define new-starting-column
            (calculate-starting-column
                                  (- (send self get-value) 1)
                                  (send hpanel-top get-width)))
          (unless (equal? starting-column new-starting-column)
            (set! starting-column new-starting-column)
            (send hpanel-top begin-container-sequence)
            (send hpanel-top change-children (lambda (x) '()))
            (send hpanel-top on-size
                  (send hpanel-top get-width)
                  (send hpanel-top get-height))
            (send hpanel-top end-container-sequence)
            (send editor-canvas refresh)
            )))))

;; Bottom right corner
(new pane%
     (parent table-panel)
     (horiz-margin 0)
     (vert-margin 0)
     (stretchable-width #f)
     (stretchable-height #f))

(send frame resize 600 400)
(send frame show #t)