(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken format))
(import (chicken process-context))
(import (chicken process signal))
(import (srfi 4))
(import (prefix sdl2 sdl2:))
(import cairo)

(sdl2:set-main-ready!)
(sdl2:init! '(video events))

(define canvas-size 400)
(define pixels-size 100)
(define scale 4)
(define status-width canvas-size)
(define status-height 40)

(define pixels-surface
  (cairo-image-surface-create CAIRO_FORMAT_RGB24 canvas-size canvas-size))
(define pixels-ctx (cairo-create pixels-surface))

(define status-surface
  (cairo-image-surface-create CAIRO_FORMAT_ARGB32 status-width status-height))
(define status-ctx (cairo-create status-surface))

(define (clean-up!)
  (cairo-surface-destroy pixels-surface)
  (cairo-surface-destroy status-surface)
  (cairo-destroy pixels-ctx)
  (cairo-destroy status-ctx)
  (sdl2:quit!))

(on-exit clean-up!)

(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (clean-up!)
     (original-handler exception))))

;; the previous thing breaks C-c quitting
(set-signal-handler! signal/int (lambda (signal) (exit)))

(define title "circle^2")
(define window (sdl2:create-window! title 0 0 canvas-size canvas-size))
(define renderer (sdl2:create-renderer! window -1 '(accelerated)))
(define pixels-texture
  (sdl2:create-texture renderer 'rgb888 'streaming canvas-size canvas-size))
(define status-texture
  (sdl2:create-texture renderer 'argb8888 'streaming status-width status-height))
(set! (sdl2:texture-blend-mode status-texture) 'blend)

(define (update-texture! texture surface)
  (cairo-surface-flush surface)
  (let ((pointer (cairo-image-surface-get-data surface))
        (stride (cairo-image-surface-get-stride surface)))
    (sdl2:update-texture-raw! texture #f pointer stride)))

(define black '(0 0 0))
(define cyan '(0 1 1))
(define magenta '(1 0 1))
(define white '(1 1 1))

(define (clear-graphics ctx)
  (apply cairo-set-source-rgb ctx white)
  (cairo-rectangle ctx 0 0 canvas-size canvas-size)
  (cairo-fill ctx))

(define pen-color (make-parameter 0))

(define (pen-color->color pen)
  (case pen
    ((0) black)
    ((1) cyan)
    ((2) magenta)
    ((3) white)))

(define (set-pen-color! color)
  (when (not (<= 0 color 3))
    (error "invalid pen color"))
  (pen-color color))

(define (draw-point ctx x y)
  (when (not (and (>= x 0) (< x pixels-size)
                  (>= y 0) (< y pixels-size)))
    (error "out of bounds"))
  (let ((color (pen-color->color (pen-color)))
        (x (* x scale))
        (y (* y scale))
        (w scale)
        (h scale))
    (apply cairo-set-source-rgb ctx color)
    (cairo-rectangle ctx x y w h)
    (cairo-fill ctx)))

(define (clear-point ctx x y)
  (parameterize ((pen-color 3))
    (draw-point ctx x y)))

(define (save! surface)
  (cairo-surface-write-to-png surface "out.png"))

(define screen-region-left-x 0)
(define screen-region-bottom-y 0)

(define (pixel-x-distance pixel-x)
  (- pixel-x screen-region-left-x))

(define (pixel-y-distance pixel-y)
  (- pixel-y screen-region-bottom-y))

(define (matching-x pixel-x square-left-x square-side-length)
  (+ square-left-x (* square-side-length
                      (/ (pixel-x-distance pixel-x) pixels-size))))

(define (matching-y pixel-y square-bottom-y square-side-length)
  (+ square-bottom-y (* square-side-length
                      (/ (pixel-y-distance pixel-y) pixels-size))))

(define (set-this-pixel? pix-x pix-y sq-left-x sq-bottom-y sq-side-length)
  (even?
   (inexact->exact
    (truncate
     (+ (expt (matching-x pix-x sq-left-x sq-side-length) 2)
        (expt (matching-y pix-y sq-bottom-y sq-side-length) 2))))))

(define (single-row-loop ctx row-y column-x sq-left-x sq-bottom-y sq-side-length)
  (if (= (- column-x screen-region-left-x) pixels-size)
      row-y
      (begin
        (set-pen-color!
         (choose-pen-color
          column-x row-y sq-left-x sq-bottom-y sq-side-length))
        (draw-point ctx column-x row-y)
        (single-row-loop
         ctx row-y (add1 column-x) sq-left-x sq-bottom-y sq-side-length))))

(define (choose-pen-color pix-x pix-y sq-left-x sq-bottom-y sq-side-length)
  (remainder
   (inexact->exact
    (truncate
     (+ (expt (matching-x pix-x sq-left-x sq-side-length) 2)
        (expt (matching-y pix-y sq-bottom-y sq-side-length) 2))))
   4))

(define (region-loop ctx row-y sq-left-x sq-bottom-y sq-side-length)
  (when (not (= (- row-y screen-region-bottom-y) pixels-size))
    (single-row-loop
     ctx row-y screen-region-left-x
     sq-left-x sq-bottom-y sq-side-length)
    (region-loop ctx (add1 row-y) sq-left-x sq-bottom-y sq-side-length)))

(define (circle-squared ctx sq-left-x sq-bottom-y sq-side-length)
  (clear-graphics ctx)
  (region-loop ctx screen-region-bottom-y sq-left-x sq-bottom-y sq-side-length))

(define left-x -10)
(define bottom-y -10)
(define sq-length 20)

(when (pair? (command-line-arguments))
  (set! left-x (string->number (car (command-line-arguments))))
  (set! bottom-y (string->number (cadr (command-line-arguments))))
  (set! sq-length (string->number (list-ref (command-line-arguments) 2))))

(define test-text "-12345 678 90")

(define (text-extents ctx text)
  (let ((extents (make-cairo-text-extents-type)))
    (cairo-text-extents ctx text extents)
    extents))

(define font-sizes '(6 8 9 10 11 12 14 18 24 30 36 48 60 72))

(define (find-font-size ctx family slant weight max-width max-height text)
  (cairo-select-font-face ctx family slant weight)
  (let loop ((last #f)
             (sizes font-sizes))
    (if (pair? sizes)
        (begin
          (cairo-set-font-size ctx (car sizes))
          (let* ((extents (text-extents ctx text))
                 (width (cairo-text-extents-width extents))
                 (height (cairo-text-extents-height extents)))
            (if (or (>= width max-width) (>= height max-height))
                last
                (loop (car sizes)(cdr sizes)))))
        last)))

(define font-size
  (find-font-size status-ctx "monospace"
                  CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
                  status-width status-height test-text))

(when (not font-size)
  (error "no suitable font size found"))

(define (center-text-vertically! ctx text width height)
  (let* ((extents (text-extents ctx text))
         (x-bearing (cairo-text-extents-x-bearing extents))
         (y-bearing (cairo-text-extents-y-bearing extents))
         (text-width (cairo-text-extents-width extents))
         (x-offset 10)
         (text-height (cairo-text-extents-height extents))
         (y-offset (/ (- height text-height) 2)))
    (cairo-move-to ctx (- x-offset x-bearing) (- y-offset y-bearing))))

(define display-status? #t)

(define (display-status ctx text)
  (cairo-set-source-rgba ctx 0 0 0 0)
  (cairo-set-operator ctx CAIRO_OPERATOR_SOURCE)
  (cairo-rectangle ctx 0 0 status-width status-height)
  (cairo-fill ctx)
  (cairo-set-operator ctx CAIRO_OPERATOR_OVER)
  (cairo-set-source-rgba ctx 1 1 1 1)
  (cairo-move-to ctx 10 30)
  (cairo-set-font-size ctx font-size)
  (center-text-vertically! ctx text status-width status-height)
  (cairo-text-path ctx text)
  (cairo-fill-preserve ctx)
  (cairo-set-source-rgba ctx 0 0 0 1)
  (cairo-set-line-width ctx 2)
  (cairo-stroke ctx))

(define status-rect
  (sdl2:make-rect 0 (- canvas-size status-height) status-width status-height))

(define (update-graphics!)
  (circle-squared pixels-ctx left-x bottom-y sq-length)
  (update-texture! pixels-texture pixels-surface)
  (when display-status?
    (display-status status-ctx (format "~a ~a ~a" left-x bottom-y sq-length))
    (update-texture! status-texture status-surface))
  (sdl2:render-clear! renderer)
  (sdl2:render-copy! renderer pixels-texture #f #f)
  (when display-status?
    (sdl2:render-copy! renderer status-texture #f status-rect))
  (sdl2:render-present! renderer))

(update-graphics!)

(let loop ((event (sdl2:make-event)))
  (when (and (not (sdl2:quit-requested?))
             (sdl2:wait-event! event))
    (case (sdl2:event-type event)
      ((window)
       (when (eqv? (sdl2:window-event-event event) 'exposed)
         (update-graphics!)))
      ((key-down)
       (case (sdl2:keyboard-event-sym event)
        ((escape q)
         (exit))
        ((left)
         (set! left-x (sub1 left-x))
         (update-graphics!))
        ((right)
         (set! left-x (add1 left-x))
         (update-graphics!))
        ((up)
         (set! bottom-y (sub1 bottom-y))
         (update-graphics!))
        ((down)
         (set! bottom-y (add1 bottom-y))
         (update-graphics!))
        ((page-up)
         (set! sq-length (sub1 sq-length))
         (update-graphics!))
        ((page-down)
         (set! sq-length (add1 sq-length))
         (update-graphics!))
        ((s)
         ;; TODO: print a message
         (save! pixels-surface))
        ((t)
         (set! display-status? (not display-status?))
         (update-graphics!)))))
    (loop event)))