#lang scheme/base

(require (planet williams/table-panel:1/table-panel)
         scheme/class
         scheme/gui/base)

(define (sublist l off)
  (let loop ((l l) (off off))
    (if (null? l) null
        (if (<= off 0) l
            (loop (cdr l) (- off 1))))))

(define (make-table-thingy parent num-rows num-columns create-row)
  (define row-handlers null)
  (define num-handlers 0)
  (define offset 0)
  
  (define pane (new horizontal-pane% (parent parent)))
  
  (define panel (new table-panel% 
                     (parent pane)
                     (alignment '(left center))
                     (dimensions (list num-rows num-columns))
                     (stretchable-width #t)
                     (stretchable-height #t)
                     (column-stretchability #t)
                     (row-stretchability #t)))
  
  (define rows
    (let loop ((left num-rows) (rows null))
      (if (<= left 0) (reverse rows)
          (let ((row (create-row panel)))
            (when (not (= (length row) num-columns))
              (error "Row must be this many columns" num-columns row))
            (loop (- left 1) (cons row rows))))))
  
  (define (refill-panel)
    (let* ((row-offset (round (/ (* (- num-handlers num-rows) (send vscroll get-value)) 10000))))
      (let loop ((row-handlers (sublist row-handlers row-offset))
                 (rows rows))
        (cond
          ((null? rows) (void))
          ((null? row-handlers) (void))
          (else
           ((car row-handlers) (car rows))
           (loop (cdr row-handlers) (cdr rows)))))))
      
  (define vscroll (new slider%
                       (parent pane)
                       (label #f)
                       (min-value 0)
                       (max-value 10000)
                       (callback
                        (λ (slider event)
                          (refill-panel)))
                       (style '(vertical plain))
                       (stretchable-width #f)
                       (stretchable-height #t)))
  
  (values
   (λ (row-handler)
     (set! row-handlers (append row-handlers (list row-handler)))
     (set! num-handlers (+ num-handlers 1)))
   refill-panel))

(define muta-button% 
  (class button%
    (init-field (my-callback void))
    (super-new (stretchable-height #t) (stretchable-width #t)
               (callback (λ (b e) (my-callback))))
    (define/public (set!-callback new-callback)
      (set! my-callback new-callback))))

(define muta-button<%> (class->interface muta-button%))

(define my-button%
  (class* muta-button% (muta-button<%>)
    (inherit set-label)
    (inherit-field my-callback)
    (init-field thingy)
    (super-new)
    (define/override (set!-callback new-callback)
      (set! my-callback (new-callback thingy)))
    (define/public (set!-number i)
      (set-label (format "fee ~s ~s" i thingy)))))

(define (test)
  (define frame (new frame% (label "feep") (width 600) (height 600)))
  
  (define-values (append flush) (make-table-thingy frame 3 3
                                                   (λ (parent)
                                                     (list
                                                      (new my-button%
                                                           (parent parent)
                                                           (thingy 'a)
                                                           (label "aaa"))
                                                      (new my-button%
                                                           (parent parent)
                                                           (thingy 'b)
                                                           (label "bbb"))
                                                      (new my-button%
                                                           (parent parent)
                                                           (thingy 'c)
                                                           (label "ggg"))))))

    
  (for-each
   (λ (i)
     (append (λ (row)
               (let loop ((left 3) (cells row))
                 (if (= left 0) (void)
                     (let ((cell (car cells)))
                       (send cell set!-number i)
                       (send cell set!-callback (λ (thingy)
                                                  (λ () (message-box "Feep" (format "Feep! ~s ~s" i thingy)))))
                       (loop (- left 1) (cdr cells))))))))
   (build-list #x100 values))
  (flush)
  (send frame show #t))

(provide (rename-out (make-table-thingy create))
         muta-button%)