(module mojo

(initialize redraw width height

 <win> make-win draw-win update-win
 win-left win-right win-top win-bottom
 win-pointer

 key-up key-down key-left key-right
 get-char)

(import chicken scheme)
(use ncurses ncurses-more posix coops
     miscmacros srfi-1 data-structures)

(define width (make-parameter #f))
(define height (make-parameter #f))
(define terminal-port (make-parameter #f))
(define absolute-wins '())

(define (redraw)
  (for-each redraw-win absolute-wins)
  (doupdate))

(define (initialize #!key (terminal (current-output-port)))
  (initscr)
  (cbreak)
  (noecho)
  (nonl)
  (intrflush (stdscr) #f)
  (keypad (stdscr) #t)
  (meta (stdscr) #t)
  (curs_set 0)
  (on-exit endwin)
  (terminal-port terminal)
  (refresh-dimensions))

(define (refresh-dimensions)
  (receive (y x) 
      (terminal-size (terminal-port))
    (width x)
    (height y)
    (resizeterm y x)
    (refresh)
    (redraw)))

(define-class <win> ()
  ((width: accessor: win-width initform: #f)
   (height: accessor: win-height initform: #f)
   (left: accessor: win-left initform: #f)
   (right: accessor: win-right initform: #f)
   (top: accessor: win-top initform: #f)
   (bottom: accessor: win-bottom initform: #f)
   (left-of: accessor: win-left-of initform: #f)
   (right-of: accessor: win-right-of initform: #f)
   (below: accessor: win-below initform: #f)
   (above: accessor: win-above initform: #f)
   (box: accessor: win-box initform: #t)
   (background: accessor: win-background initform: #f)
   (pointer accessor: win-pointer initform: #f)
   (neighbors: accessor: win-neighbors initform: '())))

(define (make-win . args)
  (apply make <win> args))

(define-method (initialize-instance after: (win <win>))
  (let ((neighbors (delete-duplicates
                    (filter identity
                            (list (win-right-of win)
                                  (win-left-of win)
                                  (win-below win)
                                  (win-above win))))))

    (if (null? neighbors)
        (push! win absolute-wins)
        (for-each (lambda (neighbor)
                    (push! win (win-neighbors neighbor)))

                  neighbors))))

(define-syntax define-win-dimension&position-accessors
  (syntax-rules ()
    ((_ dim 
        win-dim win-dim*
        win-pos win-pos*
        win-opposite-pos
        win-neighbor win-neighbor*)

     (begin

       (define-method (win-pos* (win <win>))
         (cond ((win-neighbor* win) =>
                (lambda (neighbor)
                  (- (win-pos* neighbor)
                     (win-dim* win)
                     (or (win-opposite-pos win) 0))))
               ((win-neighbor win) =>
                (lambda (neighbor)
                  (+ (win-pos* neighbor)
                     (win-dim* neighbor)
                     (or (win-pos win) 0))))
               ((win-opposite-pos win) =>
                (lambda (opp)
                  (- (dim)
                     (win-dim* win)
                     opp)))
               ((win-pos win) => identity)
               (else 0)))

        (define-method (win-dim* (win <win>))
         (or (win-dim win)
             (- (cond ((win-neighbor* win) => win-pos*)
                      (else (dim)))
                (cond ((win-neighbor win) =>
                       (lambda (neighbor)
                         (+ (or (win-pos neighbor) 0)
                            (win-dim* neighbor))))
                      (else 0))
                (or (win-opposite-pos win) 0)
                (or (win-pos win) 0))))))))

(define-win-dimension&position-accessors height
  win-height win-height*
  win-top win-top*
  win-bottom
  win-below win-above)

(define-win-dimension&position-accessors width
  win-width win-width*
  win-left win-left*
  win-right
  win-right-of win-left-of)

(define (fix-position pos size max)
  (cond ((negative? pos) 0)
        ((> (+ pos size) max) (- max size))
        (else pos)))

(define-method (update-win (win <win>) wheight wwidth top left)
  (let* ((winp (win-pointer win)))
    (if winp
        (begin
          (werase winp)
          (wnoutrefresh winp)
          (wresize winp wheight wwidth)
          (mvwin winp top left))
        (set! (win-pointer win) (newwin wheight wwidth top left)))))

(define-method (draw-win (win <win>) wheight wwidth top left)
  (let ((winp (win-pointer win)))
    (when (win-box win)
      (box winp
           (ACS_VLINE)
           (ACS_HLINE)))))

(define-method (redraw-win (win <win>))
  (let* ((wheight (win-height* win))
         (wwidth  (win-width* win))
         (top (fix-position (win-top* win) wheight (height)))
         (left (fix-position (win-left* win) wwidth (width))))
    (update-win win wheight wwidth top left)
    (draw-win win wheight wwidth top left)
    (wnoutrefresh (win-pointer win))
    (for-each redraw-win (win-neighbors win))))

(define key-up (integer->char KEY_UP))
(define key-down (integer->char KEY_DOWN))
(define key-left (integer->char KEY_LEFT))
(define key-right (integer->char KEY_RIGHT))
(define key-resize (integer->char KEY_RESIZE))

(define (get-char)
  (let ((char (getch)))
    (when (eq? char key-resize)
      (refresh-dimensions))
    char))
)