#lang debug racket
(require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt) racket/future 
         "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt")

(define-syntax (debug-report stx)
  (syntax-case stx ()
    [(_ EXPR ...) (with-syntax ([debug (datum->syntax stx 'debug)])
                    #'(when debug (report EXPR ...)))]))

(define distance-cache (make-hasheq))
(define/contract (distance q)
  (any/c . -> . real?)
  (hash-ref! distance-cache (hash-ref (attrs q) 'id q)
             (λ ()
               (cond
                 [(quad? q)
                  (match-define (list ∆x ∆y) (map - (out-point q) (in-point q)))
                  (cond
                    [(zero? ∆x) ∆y]
                    [(zero? ∆y) ∆x]
                    [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])]
                 [else 0]))))


(define+provide/contract (break xs
                                [target-size (current-wrap-distance)]
                                [debug #f]
                                #:break-val [break-val 'break]
                                #:break-before? [break-before? #f]
                                #:break-after? [break-after? #f]
                                #:hard-break-proc [hard-break? (const #f)]
                                #:soft-break-proc [soft-break? (const #f)]
                                #:finish-wrap-proc [finish-wrap-proc values])
  ((any/c) (real? any/c
                  #:break-val any/c
                  #:break-before? boolean?
                  #:break-after? boolean?
                  #:hard-break-proc procedure?
                  #:soft-break-proc procedure?
                  #:finish-wrap-proc procedure?) . ->* . (listof any/c))
  (break-hards xs
               target-size
               debug
               break-val
               break-before?
               break-after?
               hard-break?
               soft-break?
               finish-wrap-proc))

;; the hard breaks are used to divide the wrap territory into smaller chunks
;; that can be cached, parallelized, etc.
(define (break-hards xs
                     target-size
                     debug
                     break-val
                     break-before?
                     break-after?
                     hard-break?
                     soft-break?
                     finish-wrap-proc)
  (define break-val=? (if (symbol? break-val) eq? equal?))
  (define (cleanup-wraplist xs)
    (dropf-right (append* (reverse xs)) (λ (x) (break-val=? break-val x))))
  (define wraps
    (for/fold ([wraps null]
               [xs xs]
               #:result wraps)
              ([i (in-naturals)]
               #:break (null? xs))
      (match xs
        [(cons (? hard-break?) rest)
         (debug-report x 'hard-break)
         (values (cons (list break-val) wraps) rest)]
        [_ (define-values (head tail) (splitf-at xs (λ (x) (not (hard-break? x)))))
           (values (cons (cleanup-wraplist (break-softs head
                                                        target-size
                                                        debug
                                                        break-val
                                                        soft-break?
                                                        finish-wrap-proc)) wraps) tail)])))
  (append (if break-before? (list break-val) empty)
          (cleanup-wraplist wraps)
          (if break-after? (list break-val) empty)))

(define (nonprinting-at-start? x) (if (quad? x) (not (printable? x 'start)) #t))
(define (nonprinting-at-end? x) (if (quad? x) (not (printable? x 'end)) #t))
(define (break-softs qs
                     target-size
                     debug
                     break-val
                     soft-break?
                     finish-wrap-proc)
  (define start-signal (gensym))
  ;; qs = list of quads
  ;; current-dist = integer
  ;; current-wrap = list of quads ending in previous `soft-break?`
  ;; current-partial = list of unbreakable quads
  ;; wraps = list of (list of quads)
  (let loop ([wraps null][current-wrap null][current-partial null][current-dist start-signal][qs qs])
    (match qs
      [(== empty)
       (when debug (report 'all-quads-wrapped))
       ;; combine the segments into a flat list, and drop any trailing breaks
       ;; (on the idea that breaks should separate things, and there's nothing left to separate)
       ;; wraps alternate with breaks
       (for/list ([wrap (in-list (cons (append current-partial current-wrap) wraps))])
                 (match wrap
                   [(list (? nonprinting-at-end?)) wrap] ; matches break signals
                   ;; pieces will have been accumulated in reverse order
                   ;; thus beginning of list represents the end of the wrap
                   [(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...)
                    (debug-report (finish-wrap-proc (reverse rest)))
                    (finish-wrap-proc (reverse rest))]))]
      [(cons q other-qs)
       (debug-report q 'next-q)
       (define at-start? (eq? current-dist start-signal))
       #;(define underflow?
           (and (not at-start?)
                (<= (+ current-dist (if (and (quad? q) (printable? q 'end))
                                        (distance q)
                                        0)) target-size)))
       #;(define (values-for-insert-break [before? #f])
           ;; a break can be inserted before or after the current quad.
           ;; At an ordinary break (hard or soft) it goes after the wrap point.
           ;; The wrap signal consumes the break if it's nonprinting (e.g., word space or hard break)
           ;; but not if it's printing (e.g., hyphen).
           ;; But if no ordinary break can be found for a line, the wrap will happen before the quad.
           ;; The wrap signal will not consume the quad (rather, it will become the first quad in the next wrap)
           ;; (we do this by resetting next-xs to the whole xs list)
           ;; In both cases, the `finish-wrap` proc will strip off any trailing white breaks from the new segment.
           (if before?
               (values current-wrap qs)
               ; omit nonprinting quad
               (values (if (and (quad? q) (nonprinting-at-end? q))
                           current-wrap
                           (cons q current-wrap)) (cdr qs))))
       
       (define dist (and (quad? q) (printable? q (and at-start? 'start)) (distance q)))
       (debug-report dist)
       (cond
         [at-start? ; assume printing char
          (debug-report 'at-start)
          (loop wraps current-wrap (cons q current-partial) dist (cdr qs))]
         [else
          (define would-overflow? (> (+ dist current-dist) target-size))
          (cond
            [would-overflow?
             (cond
               [(soft-break? q)
                (debug-report 'would-overflow-soft)
                ;; a break is inevitable but we want to wait to finish the wrap until we see a hard quad
                ;; but we can move the current-partial into the current-wrap
                (loop wraps
                      (append (cons q current-partial) current-wrap)
                      null
                      (+ dist current-dist)
                      other-qs)]
               [else
                (debug-report 'would-overflow-hard)
                ;; finish the wrap & reset the line without consuming a quad
                (loop (list* (list break-val) (append current-partial current-wrap) wraps)
                      null
                      null
                      start-signal
                      qs)])]
            [else
             (debug-report 'would-not-overflow)
             ;; add to partial
             (loop wraps
                   current-wrap
                   (cons q current-partial)
                   (+ dist current-dist)
                   other-qs)])

          ])
       #;[(and at-start? (soft-break? q) (nonprinting-at-start? q))
          (when debug (report q 'skipping-soft-break-at-beginning))
          ;; skip it
          (loop wraps null null current-dist (cdr qs))]
       #;[(and underflow? (soft-break? q))
          (when debug (report q 'underflow-soft-break))
          (loop (list* (list break-val) pieces-for-this-wrap wraps)
                null
                current-hard
                start-signal
                next-xs)]
       ;; the easy case of accumulating quads in the middle of a wrap
       #;[(or (and underflow? (when debug (report q 'add-underflow)) #t) 
              ;; assume printing (nonprinting were handled in first case)
              ;; this branch reached if the first quad on the line causes an overflow
              ;; That sounds weird, but maybe it's just really big.
              (and at-start? (when debug (report q 'add-at-start)) #t)
              ;; we do want to accumulate nonprinting soft breaks (like wordspaces and soft hyphens) in the middle.
              ;; in case we eventually encounter a printing quad that fits on the line.
              ;; if we don't (ie. the line overflows) then they will get stripped by `finish-wrap`
              (and (soft-break? q) (nonprinting-at-end? q) (when debug (report q 'add-nonprinting-soft-break)) #t))
          (define printable (and (quad? q) (printable? q (and at-start? 'start)))) 
          (define dist (and printable (distance q)))
          (loop wraps
                (if (and (quad? q) (not printable)) current-wrap (cons q current-wrap)) ; omit nonprinting quad
                current-partial
                (if at-start? (or dist start-signal) (+ current-dist (or dist 0)))
                (cdr qs))]
       ;; the previous branch will catch all `underflow?` cases
       ;; therefore, in these last two cases, we have overflow
         
       #;[else ;; overflow implied
          ;; if we don't have an soft break stored, we need to just end the wrap and move on
          ;; we insert the break `before` so that the current quad is moved to the next wrap
          ;; no, it's not going to look good, but if we reach this point, we are in weird conditions
          (when debug (report q 'falling-back))
          (define-values (pieces-for-this-wrap next-xs) (values-for-insert-break 'before))
          (loop (list* (list break-val) pieces-for-this-wrap wraps)
                null
                current-partial
                start-signal
                next-xs)]
       ])))


(define x (q (list 'size (pt 1 1)) #\x))
(define zwx (q (list 'size (pt 0 0)) #\z))
(define hyph (q (list 'size (pt 1 1)) #\-))
(define shy (q (list 'size (pt 1 1) 'printable? (λ (sig)
                                                  (case sig
                                                    [(end) #t]
                                                    [else #f]))) #\-))
(define a (q (list 'size (pt 1 1)) #\a))
(define b (q (list 'size (pt 1 1)) #\b))
(define c (q (list 'size (pt 1 1)) #\c))
(define d (q (list 'size (pt 1 1)) #\d))
(define sp (q (list 'size (pt 1 1) 'printable? (λ (sig)
                                                 (case sig
                                                   [(start end) #f]
                                                   [else #t]))) #\space))
(define br (q (list 'size (pt 0 0) 'printable? #f) #\newline))
(define soft-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\-)))))

(define (linewrap xs size [debug #f])
  (break xs size debug
         #:break-val 'lb
         #:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
         #:soft-break-proc soft-break?))



(require rackunit)

(module+ test
  (test-case
   "chars"
   (check-equal? (linewrap (list) 1) null)  
   (check-equal? (linewrap (list a) 1) (list a))
   (check-equal? (linewrap (list a b) 1) (list a 'lb b))
   (check-equal? (linewrap (list a b c) 1) (list a 'lb b 'lb c))
   (check-equal? (linewrap (list a b c) 2) (list a b 'lb c))
   (check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x))
   (check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x))
   (check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x))
   (check-equal? (linewrap (list x x x x x) 10) (list x x x x x))))


(module+ test
    (test-case
     "chars and spaces"
     (check-equal? (linewrap (list a sp b) 1) (list a 'lb b))
     (check-equal? (linewrap (list a b sp c) 2) (list a b 'lb c))
     (check-equal? (linewrap (list a sp b) 3) (list a sp b))
     (check-equal? (linewrap (list a sp b c) 3) (list a sp b 'lb c))))

  
#;(module+ test
    (test-case
     "leading & trailing spaces"
     (check-equal? (linewrap (list sp x) 2) (list x))
     (check-equal? (linewrap (list x sp) 2) (list x))
     (check-equal? (linewrap (list sp x sp) 2) (list x))
     (check-equal? (linewrap (list sp sp x sp sp) 2) (list x))
     (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))))

#;(module+ test
    (test-case
     "hard hyphens"
     (check-equal? (linewrap (list hyph) 1) (list hyph))
     (check-equal? (linewrap (list hyph hyph) 1) (list hyph 'lb hyph))
     (check-equal? (linewrap (list hyph hyph) 2) (list hyph hyph))
     (check-equal? (linewrap (list hyph hyph hyph) 2) (list hyph hyph 'lb hyph))
     (check-equal? (linewrap (list x hyph) 1) (list x 'lb hyph))
     (check-equal? (linewrap (list x x hyph x x) 1) (list x 'lb x 'lb hyph 'lb x 'lb x))
     (check-equal? (linewrap (list x x hyph x x) 2) (list x x 'lb hyph x 'lb x))
     (check-equal? (linewrap (list x x hyph x x) 3) (list x x hyph 'lb x x))
     (check-equal? (linewrap (list x x hyph x x) 4) (list x x hyph 'lb x x))
     (check-equal? (linewrap (list x x hyph x x) 5) (list x x hyph x x))))

#;(module+ test
    (test-case
     "soft hyphens"
     (check-equal? (linewrap (list shy) 1) (list))
     (check-equal? (linewrap (list shy shy) 2) (list))
     (check-equal? (linewrap (list shy shy shy) 2) (list))
     (check-equal? (linewrap (list x shy) 1) (list x))
     (check-equal? (linewrap (list x shy shy shy shy) 1) (list x))
     (check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb x 'lb x))
     (check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb x x))
     (check-equal? (linewrap (list x x shy x x) 3) (list x x shy 'lb x x))
     (check-equal? (linewrap (list x x shy x x) 4) (list x x x x))
     (check-equal? (linewrap (list x x shy x x) 5) (list x x x x))
     (check-equal? (linewrap (list x x shy x sp x) 4) (list x x x 'lb x))))

#;(module+ test
    (test-case
     "zero width nonbreakers"
     (check-equal? (linewrap (list sp zwx) 2) (list zwx))
     (check-equal? (linewrap (list zwx sp) 2) (list zwx))
     (check-equal? (linewrap (list sp zwx sp) 2) (list zwx))
     (check-equal? (linewrap (list sp sp zwx sp sp) 2) (list zwx))
     (check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx))))

#;(module+ test
    (test-case
     "hard breaks"
     (check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things
     (check-equal? (linewrap (list a br b) 2) (list a 'lb b))
     (check-equal? (linewrap (list a b br) 2) (list a b))
     (check-equal? (linewrap (list a b br br) 2) (list a b))
     (check-equal? (linewrap (list x br x x) 3) (list x 'lb x x))
     (check-equal? (linewrap (list x x br x) 3) (list x x 'lb x))
     (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x))
     (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x))
     (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))))

#;(module+ test
    (test-case
     "hard breaks and spurious spaces"
     (check-equal? (linewrap (list a sp sp sp br b) 2) (list a 'lb b))
     (check-equal? (linewrap (list x sp br sp sp x x sp) 3) (list x 'lb x x))
     (check-equal? (linewrap (list sp sp x x sp sp br sp sp sp x) 3) (list x x 'lb x))
     (check-equal? (linewrap (list a sp b sp sp br sp c) 3) (list a sp b 'lb c))
     (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x))
     (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x))
     (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))))

(define (visual-wrap str int [debug #f])
  (apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)])
                                                           ($quad (hash-set (attrs atom) 'size '(1 1))
                                                                  (elems atom))) int debug))])
                          (cond
                            [(quad? b) (car (elems b))]
                            [else #\|]))))
#;(module+ test
    (test-case
     "visual breaks"
     (check-equal? (visual-wrap "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s")
     (check-equal? (visual-wrap "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s")
     (check-equal? (visual-wrap "My dog has fleas" 3) "My|dog|has|fle|as")
     (check-equal? (visual-wrap "My dog has fleas" 4) "My|dog|has|flea|s")
     (check-equal? (visual-wrap "My dog has fleas" 5) "My|dog|has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 6) "My dog|has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 7) "My dog|has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 8) "My dog|has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 9) "My dog|has fleas")
     (check-equal? (visual-wrap "My dog has fleas" 10) "My dog has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 11) "My dog has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 12) "My dog has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 13) "My dog has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 14) "My dog has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas")
     (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas")))


(define (pagewrap xs size [debug #f])
  (break xs size debug
         #:break-val 'pb
         #:break-before? #t
         #:hard-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
         #:soft-break-proc (λ (x) (eq? x 'lb))))
(define pbr (q '(size #f) #\page))

#;(module+ test
    (test-case
     "soft page breaks"
     (check-equal? (pagewrap null 2) '(pb))
     (check-equal? (pagewrap (list x) 2) (list 'pb x))
     (check-equal? (pagewrap (list x x) 2) (list 'pb x x))
     (check-equal? (pagewrap (list x x x) 1) (list 'pb x 'pb x 'pb x))
     (check-equal? (pagewrap (list x x x) 2) (list 'pb x x 'pb x))
     (check-equal? (pagewrap (list x x x) 3) (list 'pb x x x))
     (check-equal? (pagewrap (list x x x) 4) (list 'pb x x x))
     (check-equal? (pagewrap (list x 'lb x x) 2) (list 'pb x 'pb x x))))

#;(module+ test
    (test-case
     "hard page breaks"
     (check-equal? (pagewrap (list x pbr x x) 2) (list 'pb x 'pb x x))
     (check-equal? (pagewrap (list x pbr x x) 1) (list 'pb x 'pb x 'pb x))
     (check-equal? (pagewrap (list x pbr pbr x x) 1) (list 'pb x 'pb 'pb x 'pb x))
     (check-equal? (pagewrap (list x pbr pbr x x) 2) (list 'pb x 'pb 'pb x x))
     (check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list 'pb x 'pb x x))))

#;(module+ test
    (test-case
     "composed line breaks and page breaks"
     (check-equal? (pagewrap (linewrap null 1) 2) '(pb) )
     (check-equal? (pagewrap (linewrap (list x) 1) 2) (list 'pb x))
     (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list 'pb x 'lb x 'pb x))
     (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list 'pb x x 'pb x))
     (check-equal? (pagewrap (linewrap (list x x x) 2) 1) (list 'pb x 'pb x 'pb x))))

(struct $slug $quad () #:transparent)
(define (slug . xs) ($slug #f xs))
(define (linewrap2 xs size [debug #f])
  (break xs size debug
         #:break-val 'lb
         #:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
         #:soft-break-proc soft-break?
         #:finish-wrap-proc (λ (pcs) (list ($slug #f pcs)))))

#;(module+ test
    (test-case
     "hard breaks and spurious spaces with slugs"
     (check-equal? (linewrap2 (list a sp sp sp br b) 2) (list (slug a) 'lb (slug b)))
     (check-equal? (linewrap2 (list x sp br sp sp x x sp) 3) (list (slug x) 'lb (slug x x)))
     (check-equal? (linewrap2 (list sp sp x x sp sp br sp sp sp x) 3) (list (slug x x) 'lb (slug x)))
     (check-equal? (linewrap2 (list a sp b sp sp br sp c) 3) (list (slug a sp b) 'lb (slug c)))
     (check-equal? (linewrap2 (list x x x x) 3) (list (slug x x x) 'lb (slug x)))
     (check-equal? (linewrap2 (list x x x sp x x) 2) (list (slug x x) 'lb (slug x) 'lb (slug x x)))
     (check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x)))))