#lang racket/gui

;;; multi-dimensional arrays
(require srfi/25)

(define cell-editor%
  (class text%
    (init)
    (super-new)
    ))

(define cell-editor-admin%
  (class editor-admin%
    (init-field grid row column editor)
    
    (super-new)

    (define blinker
      (new timer% (notify-callback (lambda () (send editor blink-caret)))))
    
    (define/public (start-caret-blinking interval)
      (send blinker start interval))
    
    (define/public (stop-caret-blinking)
      (send blinker stop))

    (define/public (on-char char)
      (send editor on-char char))
    
    (define/public (on-focus on?)
      (if on?
          (send blinker start 500)
          (send blinker stop))
      (send editor on-focus on?))
    
    (define/public (redraw-editor)
      (send editor
	    refresh
	    0 0
	    (send grid get-cell-pixel-width) (send grid get-cell-pixel-height) 
            (if (eq? this (send grid get-active-admin))
		'show-caret
		'no-caret)
            #f))
    
    (define/override (get-dc (x #f) (y #f))
      (when x (set-box! x (- -2 (send grid column->x column))))
      (when y (set-box! y (- -2 (send grid row->y row))))
      (send grid get-dc) )
    
    (define/override (get-max-view x y w h (full? #f))
      (get-view x y w h full?))
    
    (define/override (get-view x y w h (full? #f))
      (when x (set-box! x 0))
      (when y (set-box! y 0))
      (when w (set-box! w (send grid get-cell-pixel-width)))
      (when h (set-box! h (send grid get-cell-pixel-height))) )
    
    (define/override (grab-caret (domain 'global))
      (when (eq? domain 'global)
        (send grid set-focus)))
    
    (define/override (modified modified?)
      (values))
    
    (define/override (needs-update x y w h)
      (send grid refresh))
    
    (define/override (popup-menu menu x y)
      #f)
    
    (define/override (refresh-delayed?)
      #f)
    
    (define/override (resized refresh?)
      (send grid refresh)) ;; only when refresh? arg ?
    
    (define/override (scroll-to x y w h (refresh? #t) (bias 'none))
      (send grid refresh)) ;; necessary ?
    
    (define/override (update-cursor)
      (values))
    
    ))

(define grid%
  (class canvas%
    (init-field nr-rows nr-columns)
    (init parent
     (min-height 0) (min-width 0)
     (stretchable-height #t) (stretchable-width #t))
    
    (define cell-char-width 5)
    (define cell-char-height 1)
    
    (super-new (parent parent)
               (min-height min-height) (min-width min-width)
               (stretchable-height stretchable-height) (stretchable-width stretchable-width))
    
    (define dc (send this get-dc))
    
    (define char-width-scale 1)
    (define char-height-scale 1.3)
    (define (char-width) (* (send dc get-char-width) char-width-scale))
    (define (char-height) (* (send dc get-char-height) char-height-scale))
    
    (display "char-width: ") (displayln (char-width))
    (display "char-height: ") (displayln (char-height))
    
    (define (cell-pixel-width) (inexact->exact (ceiling (* cell-char-width (char-width)))))
    (define (cell-pixel-height) (inexact->exact (ceiling (* cell-char-height (char-height)))))
    (define (cell+border-pixel-width) (+ (cell-pixel-width) 1))
    (define (cell+border-pixel-height) (+ (cell-pixel-height) 1))
    
    (define/public (get-cell-pixel-width) (cell-pixel-width))
    (define/public (get-cell-pixel-height) (cell-pixel-height))
    
    (define (window-height) (+ 1 (* nr-rows (cell+border-pixel-height))))
    (define (window-width) (+ 1 (* nr-columns (cell+border-pixel-width))))

;    (display "window-width: ") (displayln window-width)
;    (display "window-height: ") (displayln window-height)
    
    ;;; set window size
    (send this min-width (max min-width (window-width)))
    (send this min-height (max min-height (window-height)))
    
    (define (x->column x)
      (inexact->exact (floor (/ x (cell+border-pixel-width)))))
    (define (y->row y)
      (inexact->exact (floor (/ y (cell+border-pixel-height)))))
    (define/public (column->x column)
      (* column (cell+border-pixel-width)))
    (define/public (row->y row)
      (* row (cell+border-pixel-height)))
    
    (define (paint-cell row column color)
      (send dc set-pen "" 1 'transparent)
      (send dc set-brush color 'solid)
      (send dc draw-rectangle
            (column->x column) (row->y row)
            (cell-pixel-width) (cell-pixel-height)) )
    
    (define (write-cell row column text)
      (define x (column->x column))
      (define y (row->y row))
      (send dc set-clipping-rect x y (cell-pixel-width) (cell-pixel-height))
      ;  (send dc get-text-extent text)
      (send dc draw-text text x y)
      (send dc set-clipping-region #f))

    (define/override (on-size width height)
      ;(display "width ")(displayln width)
      ;(display "height ")(displayln height)
      (set! cell-char-width (/ width nr-columns (char-width)))
      (set! cell-char-height (/ height nr-rows (char-height))) )
    
    (define/override (on-paint)
      (send dc set-pen "black" 1 'solid)
      ;;; draw vertical grid lines
      (for ((c (in-range 1 nr-columns)))
        (let ((x (- (* c (cell+border-pixel-width)) 1)))
          (send dc draw-line x 0 x (window-height))))
      ;;; draw horizontal grid lines
      (for ((r (in-range 1 nr-rows)))
        (let ((y (- (* r (cell+border-pixel-height)) 1)))
          (send dc draw-line 0 y (window-width) y)))
      ;;; draw grid contents
      (for* ((r (in-range 0 nr-rows))
             (c (in-range 0 nr-columns)) )
        (send (array-ref admins r c) redraw-editor) )

      (paint-cell 1 1 (make-object color% 200 100 50 1.0))
      (paint-cell 5 5 (make-object color% 50 200 100 1.0))      
      (paint-cell 2 3 (make-object color% 50 50 200 1.0))
      )
    
    (define/override (on-event event)
      (define column (x->column (send event get-x)))
      (define row (y->row (send event get-y)))
      (define type (send event get-event-type))
      (case type
        ((motion)
         (if (send event dragging?)
             (handle-dragging event)
             (handle-motion event)))
        ((left-down)
         (handle-left-down event row column))  ))
    
    (define/override (on-char char)
      (send active-admin on-char char))
    
    (define/override (on-focus on?)
      (send active-admin on-focus on?)
      (send this refresh)
      )

    (define (handle-dragging event)
      (print event))
    
    (define (handle-motion event)
      #f)
    
    (define (change-active-cell row column)
      (send active-admin on-focus #f)
      (set! active-admin (array-ref admins row column))
      (send active-admin on-focus #t) )
    
    (define (handle-left-down event row column)
      (change-active-cell row column)
      ;      (paint-cell row column (make-object color% 50 50 200 1.0)))
      #;(write-cell row column "ÀFjgG30093") )

    (define admins (make-array (shape 0 nr-rows 0 nr-columns)))
    
    (for* ((r (in-range 0 nr-rows))
           (c (in-range 0 nr-columns)) )
      (define editor (new cell-editor%))
      (define admin (new cell-editor-admin% (grid this) (editor editor) (row r) (column c)))
      (array-set! admins r c admin)
      (send editor set-admin admin) )
    
    (define active-admin (array-ref admins 0 0))
    
    (define/public (get-active-admin)
      active-admin)

    ))

(define root (new frame% (label "Grid Test")))

(define grid
  (new grid%
       (parent root)
       (nr-rows 4) (nr-columns 5)
       (min-width 50) (min-height 50)
       (style '(border resize-corner) #;'(combo control-border))))

(send root show #t)
