#lang typed/racket

(require typed/racket/gui
         typed/framework
         string-constants)
(require/typed racket/gui/base
               [get-label-background-color
                (-> (Instance Color%))])
(require/typed framework/main
               [color-prefs:white-on-black-color-scheme?
                (-> Boolean)])
(provide insert-large-letters)

(: insert-large-letters (String Char (Instance Text:Basic<%>) (Instance Frame%) -> Void))
(define (insert-large-letters comment-prefix comment-character edit parent)
  (let ([str (make-large-letters-dialog comment-prefix comment-character #f)])
    (when (and str
               (not (equal? str "")))
      (render-large-letters comment-prefix comment-character (get-chosen-font) str edit #f)
      (void))))

(: get-default-font (-> (Instance Font%)))
(define (get-default-font)
  (send (assert (send (editor:get-standard-style-list)
                      find-named-style
                      "Standard"))
        get-font))

(: get-chosen-font (-> (Instance Font%)))
(define (get-chosen-font)
  (define-values (face size) (get-current-pref))
  (cond
    [face
     (let ([candidate
            (send the-font-list find-or-create-font
                  size
                  face
                  'default 'normal 'normal)])
       (if (equal? (send candidate get-face) face)
           candidate
           (get-default-font)))]
    [else
     (get-default-font)]))

(: get-current-pref : (-> (Values (U String False) Real)))
(define (get-current-pref)
  (define pref-val (preferences:get 'drracket:large-letters-font))
  (cond
    [(not pref-val)
     (define fnt (get-default-font))
     (values (send fnt get-face)
             (send fnt get-point-size))]
    [else
     ;; this cast (should) never fail because of the way
     ;; 'drracket:large-letters-font is initialized in main.rkt
     (define pref-val-typed (cast pref-val (Pairof (U String False) Real)))
     (values (car pref-val-typed) (cdr pref-val-typed))]))

(: set-current-pref (-> (U String False) Real Void))
(define (set-current-pref face size)
  (unless (<= 0 size 1024) (error 'set-current-pref "face size out of range, got ~s" size))
  (preferences:set 'drracket:large-letters-font (cons face size)))

(define columns-string "~a columns")

(: make-large-letters-dialog (String Char (Option (Instance Frame%)) -> (Option String)))
(define (make-large-letters-dialog comment-prefix comment-character parent)
  (define dlg (new (frame:focus-table-mixin dialog%)
                   [parent parent]
                   [style '(close-button)]
                   [width 700]
                   [label (string-constant large-semicolon-letters)]))
  (define: text-field : (Instance Text-Field%) 
    (new text-field% 
         [parent dlg] 
         [label (string-constant text-to-insert)]
         [callback (λ (x y) (update-txt (send text-field get-value)))]))
  (: info-bar (Instance Horizontal-Panel%))
  (define info-bar (new horizontal-panel%
                        [parent dlg]
                        [stretchable-height #f]))
  (define: font-choice : (Instance Choice%)
    (let ([tmp-bdc (new bitmap-dc% [bitmap (make-bitmap 1 1 #f)])])
      (new choice%
           [label (string-constant font-name)]
           [parent info-bar]
           [choices (get-face-list)]
           [callback
            (λ (x y)
              (define choice (send font-choice get-selection))
              (when choice
                (define-values (current-font current-size) (get-current-pref))
                (set-current-pref (list-ref (get-face-list) choice) current-size)
                (update-txt (send text-field get-value))))])))
  (: font-size-field (Instance Text-Field%))
  (define font-size-field
    (new text-field%
         [parent info-bar]
         [stretchable-width #f]
         [callback (λ (x y)
                     (define n (string->number (send font-size-field get-value)))
                     (cond
                       [(and n (real? n) (<= 0 n 1024))
                        (send font-size-field set-field-background #f)
                        (define-values (current-font current-size) (get-current-pref))
                        (set-current-pref current-font n)
                        (update-txt (send text-field get-value))]
                       [else
                        (define name 'framework:failed-search-background-color)
                        (cond
                          [(and (color-prefs:known-color-scheme-name? name)
                                (color-prefs:color-scheme-color-name? name))
                           (send font-size-field set-field-background
                                 (color-prefs:lookup-in-color-scheme name))]
                          [else
                           ;; can't happen because `'framework:failed-search-background-color` is always
                           ;; in the set of color names but the type system doesn't know that
                           (send font-size-field set-field-background warning-background)])]))]
         [label (string-constant font-size)]))

  (: warning-background (Instance Color%))
  (define warning-background (assert (send the-color-database find-color "pink")))
  
  (: count (Instance Message%))
  (define count (new message% [label (format columns-string 1000)] [parent info-bar]))
  (: pane1 (Instance Horizontal-Pane%))
  (define pane1 (new horizontal-pane% (parent info-bar)))
  (: dark-msg (Object [set-bm ((Option (Instance Bitmap%)) -> Void)]))
  (define dark-msg (new bitmap-message% [parent info-bar]))
  (: pane2 (Instance Horizontal-Pane%))
  (define pane2 (new horizontal-pane% (parent info-bar)))
                                
  (: txt (Instance Text:Basic%))
  (define txt (new racket:text%))
  (: ec (Instance Editor-Canvas%))
  (define ec (new canvas:color% [parent dlg] [editor txt]))
  (: button-panel (Instance Horizontal-Panel%))
  (define button-panel (new horizontal-panel%
                            [parent dlg]
                            [stretchable-height #f]
                            [alignment '(right center)]))
  (define: ok? : Boolean #f)
  (: ok Any)
  (: cancel Any)
  (define-values (ok cancel)
    (gui-utils:ok/cancel-buttons button-panel
                                 (λ (x y) (set! ok? #t) (send dlg show #f))
                                 (λ (x y) (send dlg show #f))))
  (: update-txt (String -> Any))
  (define (update-txt str)
    (send dlg begin-container-sequence)
    (send txt begin-edit-sequence)
    (send txt lock #f)
    (send txt delete 0 (send txt last-position))
    (let ([bm (render-large-letters comment-prefix comment-character (get-chosen-font) str txt #t)])
      (send ec set-line-count (+ 1 (send txt last-paragraph)))
      (send dlg resize 0 0)
      (send txt lock #t)
      (send txt end-edit-sequence)
      (send count set-label (format columns-string (get-max-line-width txt)))
      (send dark-msg set-bm (if (equal? str "") #f bm)))
    (send dlg end-container-sequence))
  
  
  (let ()
    (define-values (face size) (get-current-pref))
    ;; CHANGE - get-face can return #f
    (when face
      (let loop ([i 0]
                 [faces (get-face-list)])
        (cond
          [(null? faces) (void)]
          [else (cond
                  [(equal? face (car faces))
                   (send font-choice set-selection i)]
                  [else
                   (loop (+ i 1) (cdr faces))])])))
    (send font-size-field set-value (~a size)))
  
  (send txt auto-wrap #f)
  (update-txt "")
  (send text-field focus)
  (send dlg show #t)
  (and ok? (send text-field get-value)))

(: get-max-line-width ((Instance Text:Basic<%>) -> Real))
(define (get-max-line-width txt)
  (let loop ([i (+ (send txt last-paragraph) 1)]
             [m 0])
    (cond
      [(zero? i) m]
      [else (loop (sub1 i)
                  (max m (- (send txt paragraph-end-position (- i 1))
                            (send txt paragraph-start-position (- i 1)))))])))

(define bitmap-message%
  (class canvas%
    (inherit min-width min-height get-dc refresh get-client-size)
    (: bm (Option (Instance Bitmap%)))
    (define bm #f)
    (define/override (on-paint)
      (define bm* bm)
      (define dc (get-dc))
      (cond
        [bm*
         (send dc draw-bitmap bm* 0 0)]
        [else
         (define color (get-label-background-color))
         (define-values (cw ch) (get-client-size))
         (define brush (send dc get-brush))
         (define pen (send dc get-pen))
         (send dc set-brush color 'solid)
         (send dc set-pen color 1 'transparent)
         (send dc draw-rectangle 0 0 cw ch)
         (send dc set-brush brush)
         (send dc set-pen pen)])
      (void))
    (: set-bm ((Option (Instance Bitmap%)) -> Void))
    (define/public (set-bm b)
      (set! bm b)
      (define bm* bm)
      (cond
        [bm*
         (when (color-prefs:white-on-black-color-scheme?)
           (invert-bm bm*))
         (min-width (send bm* get-width))
         (min-height (send bm* get-height))]
        [else
         (min-width 0)
         (min-height 0)])
      (refresh))
    (super-new (stretchable-width #f)
               (stretchable-height #f)
               (style '(no-focus)))))

(: invert-bm (-> (Instance Bitmap%) Void))
(define (invert-bm bm)
  (define w (send bm get-width))
  (define h (send bm get-height))
  (define argb (make-bytes (* w h 4)))
  (send bm get-argb-pixels 0 0 w h argb)
  (for ([i (in-range 0 (* w h 4) 4)])
    (bytes-set! argb (+ i 1) (- 255 (bytes-ref argb (+ i 1))))
    (bytes-set! argb (+ i 2) (- 255 (bytes-ref argb (+ i 2))))
    (bytes-set! argb (+ i 3) (- 255 (bytes-ref argb (+ i 3)))))
  (send bm set-argb-pixels 0 0 w h argb))
  

(: render-large-letters (-> String Char (Instance Font%) String (Instance Text:Basic<%>) Boolean
                            (Instance Bitmap%)))
(define (render-large-letters comment-prefix comment-character the-font str edit color-insertion?)
  (define bdc (new bitmap-dc% [bitmap (make-bitmap 1 1 #t)]))
  (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font 'grapheme))
  (define th (let-values ([(_1 h _2 _3) (send bdc get-text-extent "X" the-font 'grapheme)])
               (max raw-th h)))
  (define tmp-color (make-object color%))
  
  (: get-char (Real Real -> Char))
  (define (get-char x y)
    (send bdc get-pixel x y tmp-color)
    (define max-color
      (max (send tmp-color red)
           (send tmp-color green)
           (send tmp-color blue)))
    (if (<= max-color 80)
        comment-character
        #\space))
  (define bitmap
    (make-object bitmap%
      (max 1 (exact-floor tw))
      (assert (max 1 (exact-floor th)) positive?)
      #t))
  
  (: fetch-line (Real -> String))
  (define (fetch-line y)
    (let loop ([x (send bitmap get-width)]
               [#{chars : (Listof Char)} null])
      (cond
        [(zero? x) (apply string chars)]
        [else (loop (- x 1) (cons (get-char (- x 1) y) chars))])))
  
  (send bdc set-bitmap bitmap)
  (send bdc clear)
  (send bdc set-font the-font)
  (send bdc draw-text str 0 0 'grapheme)
  
  (send edit begin-edit-sequence)
  (let ([start (send edit get-start-position)]
        [end (send edit get-end-position)])
    (send edit delete start end)
    (send edit insert "\n" start start)
    (let loop ([y (send bitmap get-height)])
      (unless (zero? y)
        (send edit insert (fetch-line (- y 1)) start start)
        (send edit insert comment-prefix start start)
        (send edit insert "\n" start start)
        (loop (- y 1)))))


  (when color-insertion?
    (define name 'framework:syntax-color:scheme:comment)
    (define sd
      (cond
        [(and (color-prefs:known-color-scheme-name? name)
              (color-prefs:color-scheme-style-name? name))
         ;; cast won't fail because of the above condition
         (cast (color-prefs:lookup-in-color-scheme name)
               (Instance Style-Delta%))]
        [else
         ;; shouldn't happen, but types aren't strong enough to prove it.
         (send (editor:get-standard-style-list) find-named-style
               (editor:get-default-color-style-name))]))
    (send edit change-style
          sd
          0
          (send edit last-position)))
  
  (send edit end-edit-sequence)
  (send bdc set-bitmap #f)
  bitmap)

(module+ main
  ;; this initialization code copied from main.rkt
  ;; but modified to remove the predicate; beware
  ;; that bad contents of the preferences file may
  ;; lead to asssertion failures. If they do, evaluate
  ;; (preferences:set 'drracket:large-letters-font #f)
  ;; to restore the preference setting to its default
  (preferences:set-default 'drracket:large-letters-font #f (λ (x) #t))
  (make-large-letters-dialog ";" #\; #f))
