(define-module (guart)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 streams)
  #:use-module (uniseg)
  #:use-module (uniseg graphemes)
  #:use-module (uniseg graphemes stream)
  #:use-module (uniseg graphemes iterator)
  #:export (<guart>
            guart?
            guart-w
            guart-h
            guart-draw
            blank
            char
            text
            place-at
            mask
            crop
            if-drawn
            place-cursor-after
            matte-at
            matte
            inset
            vap
            end2
            vappend
            vappend*
            happend2
            happend
            happend*
            hline
            vline
            frame))

(define (rectangle-intersect a-x1 a-y1
                             a-x2 a-y2
                             b-x1 b-y1
                             b-x2 b-y2)
  (and (< a-x1 b-x2)
       (> a-x2 b-x1)
       (< a-y1 b-y2)
       (> a-y2 b-y1)))

(define-immutable-record-type <guart>
  (guart w h draw)
  guart?
  (w guart-w)
  (h guart-h)
  (draw guart-draw))


(define* (blank #:optional (w 0) (h 1))
  (guart w h (λ (okay? blit! rpos cpos) #f)))

(define (char ch)
  (define grapheme (char->grapheme ch))
  (unless grapheme
    (scm-error 'convert-failure "char" "Unable to convert ~s to a valid unicode grapheme" (list ch) (list ch)))

  (guart
   1 1
   (λ (okay? blit! rpos cpos)
     (blit! rpos cpos grapheme)
     #f)))

;; TODO: detect non-printable characters other than newline
;; We need to discard them and also handle escape codes/printing those, etc.
(define* (text str #:key (halign #f))
  (define contains-newline? (string-index str #\newline))
  (if contains-newline?
      (if halign
          (vappend* (map text (string-split str #\newline)) #:halign halign)
          (scm-error 'keyword-argument-error "text" "String contained newlines but no halign argument was set" '() (list halign)))
      (guart
       (string-width str) 1
       (λ (okay? blit! rpos cpos)
         ;; Go through each grapheme, print it and advance the position
         ;; depending on the width
         (fold
          (λ (gr c)
            (blit! rpos c gr)
            (+ c (grapheme-width gr)))
          cpos
          (string->grapheme-list str))
         #f))))

(define (place-at back row-offset col-offset front)
  (match-let ((($ <guart> bw bh draw-b) back)
              (($ <guart> fw fh draw-f) front))
    (guart bw bh
     (λ (okay? blit! rpos cpos)
       (or (draw-b okay? blit! rpos cpos)
           (draw-f okay? blit! (+ rpos row-offset) (+ cpos col-offset)))))))

(define (matte-at matte-width matte-height cpos rpos x)
  (match-let ((($ <guart> xw xh _) x))
    (unless (and (<= (+ xw cpos) matte-width)
                 (<= (+ xh rpos) matte-height))
      (scm-error 'matte-error "matte-at" "Original (~ax~a@~a,~a) must fit inside matte (~ax~a)" (list xw xh cpos rpos matte-width matte-height) (list x)))
    (place-at (blank matte-width matte-height) rpos cpos x)))

(define* (matte matte-width matte-height x #:key (halign 'center) (valign 'center))
  (define width (or matte-width (guart-w x)))
  (define height (or matte-height (guart-h x)))
  (match-let ((($ <guart> xw xh draw-x) x))
    (unless (and (<= xw width)
                 (<= xh height))
      (scm-error 'matte-error "matte" "Original (~ax~a) must fit inside matte (~ax~a)" (list xw xh width height) (list x)))

    (matte-at width height
              (match halign
                ('left 0)
                ('center (floor (/ (- width xw) 2)))
                ('right (- width xw)))
              (match valign
                ('top 0)
                ('center (floor (/ (- height xh) 2)))
                ('bottom (- height xh)))
              x)))

(define (inset width-offset height-offset x)
  (match-let ((($ <guart> xw xh _) x))
    (matte (+ width-offset xw width-offset)
           (+ height-offset xh height-offset)
           x
           #:halign 'center #:valign 'center)))

(define (translate row-offset col-offset x)
  (match-let ((($ <guart> xw xh _) x))
    (matte-at (+ xw col-offset) (+ xh row-offset) col-offset row-offset x)))


(define (mask mask-cpos mask-width mask-rpos mask-height x)
  (match-let ((($ <guart> xw xh draw-x) x))
    (guart xw xh
     (λ (okay? blit! rpos cpos)
       (draw-x
        ;; okay? function definition for this art
        (λ (width height rpos cpos)
          (and (okay? width height rpos cpos)
               (rectangle-intersect mask-cpos mask-rpos
                                    (+ mask-cpos mask-width) (+ mask-rpos mask-height)
                                    cpos rpos
                                    (+ cpos width) (+ rpos height))))
        blit! rpos cpos))
     )))


(define (crop crop-cpos crop-width crop-rpos crop-height x)
  (define mask-x (mask crop-cpos crop-width crop-rpos crop-height x))
  (match-let ((($ <guart> _ _ draw-m) mask-x))
    (guart
     crop-width
     crop-height
     (λ (okay? blit! rpos cpos)
       (draw-m
        ;; okay? function definition for this art
        (λ (width height rpos cpos)
          (okay? width height (- rpos crop-rpos) (- cpos crop-cpos)))
        ;; blit! function definition for this art
        (λ (rpos cpos ch)
          (blit! (- rpos crop-rpos) (- cpos crop-cpos) ch))
        rpos cpos)))))

(define (if-drawn func x)
  (match-let ((($ <guart> xw xh draw-x) x))
    (guart xw xh
           (λ (okay? blit! rpos cpos)
             (define ? (draw-x okay? blit! rpos cpos))
             (when ? (func rpos cpos ))
             ?))))

(define (place-cursor-after x cursor-rpos cursor-cpos)
  (match-let ((($ <guart> xw xh draw-x) x))
    (guart xw xh
           (λ (okay? blit! rpos cpos)
             (or (draw-x okay? blit! rpos cpos)
                 (blit! cursor-rpos cursor-cpos #f))))))

(define (strip-keywords lst)
  (match lst
    (((? keyword? kw) arg . remainder) (strip-keywords remainder))
    ((item . remainder) (cons item (strip-keywords remainder)))
    (item item)))

(define* (*vappend2 y x #:key (reverse? #f))
  (match-let ((($ <guart> xw xh draw-x) x)
              (($ <guart> yw yh draw-y) y))
    (unless (= xw yw)
      (scm-error 'append-error "vappend2" "Widths must be equal: ~a vs ~a" (list xw yw) (list xw yw)))
    (guart
     xw (+ xh yh)
     (λ (okay? blit! rpos cpos)
       (define (dx) (draw-x okay? blit! rpos cpos))
       (define (dy) (draw-y okay? blit! (+ rpos xh) cpos))
       (if reverse?
           (or (dy) (dx))
           (or (dx) (dy)))))))

(define* (vappend2 y x #:key (halign #f) (reverse? #f))
  (cond
   ((not halign) (*vappend2 y x #:reverse? reverse?))
   (else
    (match-let ((($ <guart> xw xh draw-x) x)
                (($ <guart> yw yh draw-y) y))
      (define new-width (max xw yw))
      (define x-paint (matte new-width xh x #:halign halign))
      (define y-paint (matte new-width yh y #:halign halign))
      (*vappend2 y-paint x-paint #:reverse? reverse?)))))

(define* (vappend r1 #:key (halign #f) (reverse? #f) #:rest rs)
  (fold (λ (a d) (vappend2 a d #:halign halign #:reverse? reverse?)) r1 (strip-keywords rs)))

(define* (vappend* rs #:key (halign #f) (reverse? #f))
  (apply vappend (car rs) #:halign halign #:reverse? reverse? (cdr rs)))

(define* (*happend2 y x #:key (reverse? #f))
  (match-let ((($ <guart> xw xh draw-x) x)
              (($ <guart> yw yh draw-y) y))
    (unless (= xh yh)
      (scm-error 'append-error "happend2" "Heights must be equal: ~a vs ~a" (list xh yh) (list xh yh)))
    (guart
     (+ xw yw) xh
     (λ (okay? blit! rpos cpos)
       (define (dx) (draw-x okay? blit! rpos cpos))
       (define (dy) (draw-y okay? blit! rpos (+ cpos xw)))
       (if reverse?
           (or (dy) (dx))
           (or (dx) (dy)))))))

;; TODO: for both v and h: need to better detect and error if the alignments are not set and are needed.
(define* (happend2 y x #:key (valign #f) (reverse? #f))
  (cond
   ((not valign) (*happend2 y x #:reverse? reverse?))
   (else
    (match-let ((($ <guart> xw xh draw-x) x)
                (($ <guart> yw yh draw-y) y))
      (define new-height (max xh yh))
      (define x-paint (matte xw new-height x #:valign valign))
      (define y-paint (matte yw new-height y #:valign valign))
      (*happend2 y-paint x-paint #:reverse? reverse?)))))

(define* (happend r1 #:key (valign #f) (reverse? #f) #:rest rs)
  (fold (λ (a d) (happend2 a d #:valign valign #:reverse? reverse?)) r1 (strip-keywords rs)))

(define* (happend* rs #:key (valign #f) (reverse? #f))
  (apply happend (car rs) #:valign valign #:reverse? reverse? (cdr rs)))

(define* (hline w #:key (ch #\─))
  (text (make-string w ch)))

(define* (vline h #:key (ch #\│))
  (vappend* (make-list h (char ch))))

(define* (frame x
         #:key
         (top-left #\┌)
         (top-right #\┐)
         (bottom-left #\└)
         (bottom-right #\┘)
         (horiz-line #\─)
         (vert-line #\│))
  (match-let* ((($ <guart> width height _) x)
               (hl (hline width #:ch horiz-line))
               (vl (vline height #:ch vert-line))
               (bl (blank width height)))
    (place-at
     (vappend
      (happend (char top-left) hl (char top-right))
      (happend vl bl vl)
      (happend (char bottom-left) hl (char bottom-right)))
     1 1 x)))