#lang scheme/base

(require (rename-in "pict.rkt"
                    [hline t:hline]
                    [vline t:vline]
                    [frame t:frame])
         "convertible.rkt"
         (rename-in "utils.rkt"
                    [pin-line t:pin-line]
                    [pin-arrow-line t:pin-arrow-line]
                    [pin-arrows-line t:pin-arrows-line])
         (only-in racket/draw dc-path% make-bitmap bitmap% bitmap-dc% color%)
         (only-in racket/class new send make-object is-a?/c)
         racket/contract)

(define (hline w h #:segment [seg #f])
  (if seg
      (dash-hline w h seg)
      (t:hline w h)))

(define (vline w h #:segment [seg #f])
  (if seg
      (dash-vline w h seg)
      (t:vline w h)))

(define (frame p
               #:color [col #f]
               #:line-width [lw #f]
               #:segment [seg #f])
  (let* ([p (pict-convert p)]
         [f (if seg
                (dash-frame (launder (ghost p)) seg)
                (t:frame (launder (ghost p))))]
         [f (if col
                (colorize f col)
                f)]
         [f (if lw 
                (linewidth lw f)
                f)])
    (refocus (cc-superimpose p f)
             p)))

(define (label-line label pict src-pict src-coord-fn dest-pict dest-coord-fn
                    #:x-adjust [x-adjust 0] #:y-adjust [y-adjust 0])
  (let-values ([(src-x src-y) (src-coord-fn pict src-pict)]
               [(dest-x dest-y) (dest-coord-fn pict dest-pict)])
    (let* ([src (make-rectangular src-x src-y)]
           [dest (make-rectangular dest-x dest-y)]
           [adjust (make-rectangular x-adjust y-adjust)]
           [v (- dest src)]
           [h2 (pict-height label)])
      ;; Ensure that the src is left of dest
      (when (< (real-part v) 0)
        (set! v (- v))
        (set! src dest))
      (let ([p (+ src
                  ;; Move the label to sit atop the line.
                  (/ (* h2 -i v) (magnitude v) 2)
                  ;; Center the label in the line.
                  (/ (- v (make-rectangular (pict-width label)
                                            (pict-height label)))
                     2)
                  adjust)])
        (pin-over
         pict
         (real-part p)
         (imag-part p)
         label)))))

(define (pin-line p 
                  src src-find
                  dest dest-find
                  #:start-angle [sa #f] #:end-angle [ea #f]
                  #:start-pull [sp #f] #:end-pull [ep #f]
                  #:color [col #f]
                  #:alpha [alpha 1.0]
                  #:line-width [lw #f]
                  #:under? [under? #f]
                  #:solid? [solid? #t]
                  #:style [style #f]
                  #:label [label #f]
                  #:x-adjust-label [x-adjust 0]
                  #:y-adjust-label [y-adjust 0])
  (define line
    (if (not (or sa ea))
        (finish-pin (launder (t:pin-line (ghost p)
                                         src src-find 
                                         dest dest-find
                                         #:style style))
                    p lw col alpha under?)
        (pin-curve* #f #f p src src-find dest dest-find
                    sa ea sp ep 0 col lw under? #t
                    style alpha)))
  (if label
      (label-line label line src src-find dest dest-find
                  #:x-adjust x-adjust #:y-adjust y-adjust)
      line))

(define (pin-arrow-line sz p 
                        src src-find
                        dest dest-find
                        #:start-angle [sa #f] #:end-angle [ea #f]
                        #:start-pull [sp #f] #:end-pull [ep #f]
                        #:color [col #f]
                        #:alpha [alpha 1.0]
                        #:line-width [lw #f]
                        #:under? [under? #f]
                        #:solid? [solid? #t]
                        #:style [style #f]
                        #:hide-arrowhead? [hide-arrowhead? #f]
                        #:label [label #f]
                        #:x-adjust-label [x-adjust 0]
                        #:y-adjust-label [y-adjust 0])
  (define line
    (if (not (or sa ea))
        (finish-pin (launder (t:pin-arrow-line sz (ghost p)
                                               src src-find 
                                               dest dest-find
                                               #f #f #f solid?
                                               #:hide-arrowhead? hide-arrowhead?
                                               #:style style))
                    p lw col alpha under?)
        (pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find
                    sa ea sp ep sz col lw under? solid?
                    style alpha)))
  (if label
      (label-line label line src src-find dest dest-find
                  #:x-adjust x-adjust #:y-adjust y-adjust)
      line))
  
(define (pin-arrows-line sz p 
                         src src-find
                         dest dest-find
                         #:start-angle [sa #f] #:end-angle [ea #f]
                         #:start-pull [sp #f] #:end-pull [ep #f]
                         #:color [col #f]
                         #:alpha [alpha 1.0]
                         #:line-width [lw #f]
                         #:under? [under? #f]
                         #:solid? [solid? #t]
                         #:style [style #f]
                         #:hide-arrowhead? [hide-arrowhead? #f]
                         #:label [label #f]
                         #:x-adjust-label [x-adjust 0]
                         #:y-adjust-label [y-adjust 0])
  (define line
    (if (not (or sa ea))
        (finish-pin (launder (t:pin-arrows-line sz (ghost p)
                                                src src-find 
                                                dest dest-find
                                                #f #f #f solid?
                                                #:hide-arrowhead? hide-arrowhead?
                                                #:style style))
                    p lw col alpha under?)
        (pin-curve* (not hide-arrowhead?) (not hide-arrowhead?)
                    p src src-find dest dest-find
                    sa ea sp ep sz col lw under? solid? 
                    style alpha)))
  (if label
      (label-line label line src src-find dest dest-find
                  #:x-adjust x-adjust #:y-adjust y-adjust)
      line))
    
(define (pin-curve* start-arrow? end-arrow? p 
                    src src-find
                    dest dest-find
                    sa ea sp ep
                    sz col lw
                    under? solid?
                    style alpha)
  (let-values ([(sx0 sy0) (src-find p src)]
               [(dx0 dy0) (dest-find p dest)])
    (let* ([sa (or sa
                   (get-angle (- sy0 dy0) (- dx0 sx0)))]
           [ea (or ea
                   (get-angle (- sy0 dy0) (- dx0 sx0)))]
           [d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))]
           [sp (* (or sp 1/4) d)]
           [ep (* (or ep 1/4) d)])
      (let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)]
            [dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)]
            [sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)]
            [sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)]
            [path (new dc-path%)]
            [maybe-pin-line
             (lambda (arrow? p sx sy dx dy)
               (if arrow?
                   (pin-arrow-line 
                    sz
                    p
                    p (lambda (a b) (values sx sy))
                    p (lambda (a b) (values dx dy))
                    #:line-width lw
                    #:color col
                    #:under? under?
                    #:solid? solid?
                    #:style style
                    #:alpha alpha)
                   p))])
        (send path move-to sx sy)
        (send path curve-to
              (+ sx (* sp (cos sa)))
              (- sy (* sp (sin sa)))
              (- dx (* ep (cos ea)))
              (+ dy (* ep (sin ea)))
              dx
              dy)
        (maybe-pin-line 
         start-arrow?
         (maybe-pin-line 
          end-arrow?
          ((if under? pin-under pin-over)
           p
           0 0
           (let* ([p (dc (lambda (dc x y)
                           (let ([b (send dc get-brush)])
                             (send dc set-brush "white" 'transparent)
                             (send dc draw-path path x y)
                             (send dc set-brush b)))
                         0 0)]
                  [p (if col
                         (colorize p col)
                         p)]
                  [p (if (= alpha 1.0)
                         p
                         (cellophane p alpha))]
                  [p (if lw
                         (linewidth lw p)
                         p)]
                  [p (if style
                         (linestyle style p)
                         p)])
             p))
          dx dy dx0 dy0)
         sx sy sx0 sy0)))))


(define (finish-pin l p lw col alpha under?)
  (let* ([l (if lw
                (linewidth lw l)
                l)]
         [l (if col
                (colorize l col)
                l)]
         [l (if (= alpha 1.0)
                l
                (cellophane l alpha))])
    (if under?
        (cc-superimpose l p)
        (cc-superimpose p l))))

(define fish
  (let ([standard-fish
         (lambda (w h 
                    #:direction [direction 'left]
                    #:color [color "blue"]
                    #:eye-color [eye-color "black"]
                    #:open-mouth [open-mouth #f])
           (standard-fish w h direction color eye-color open-mouth))])
    standard-fish))

(define (pict->bitmap p [smoothing 'aligned]
                      #:make-bitmap [make-bitmap make-bitmap])
  (define w (pict-width p))
  (define h (pict-height p))
  (define bm (make-bitmap (max 1 (inexact->exact (ceiling w)))
                          (max 1 (inexact->exact (ceiling h)))))
  (unless (send bm ok?)
    (error 'pict->bitmap
           (string-append "bitmap creation failed\n"
                          "  possible reason: out of memory\n"
                          "  pict width: ~a\n"
                          "  pict height: ~a")
           w
           h))
  (define dc (make-object bitmap-dc% bm))
  (send dc set-smoothing smoothing)
  (draw-pict p dc 0 0)
  bm)
  
(define (pict->argb-pixels p [smoothing 'aligned])
  (define bm (pict->bitmap p smoothing))
  (define w (send bm get-width)) 
  (define h (send bm get-height))
  (define bytes (make-bytes (* w h 4)))
  (send bm get-argb-pixels 0 0 w h bytes)
  bytes)
  
(define (argb-pixels->pict b w)
  (define h (/ (bytes-length b) w 4))
  (define bm (make-bitmap w (/ (bytes-length b) w 4)))
  (send bm set-argb-pixels 0 0 w h b)
  (bitmap bm))

(define (freeze p
                #:inset [_inset 0]
                #:scale [extra-scale 1])
  (define inset-list
    (cond
      [(real? _inset) (list _inset)]
      [else _inset]))
  (define p* (pict-convert p))
  (define sized (scale (apply inset p* inset-list) extra-scale))
  (define frozen (bitmap (pict->bitmap sized)))
  (define unsized (apply inset (scale frozen (/ extra-scale)) (map - inset-list)))
  (struct-copy pict p* [draw (pict-draw unsized)]))

(provide hline vline
         frame
         pict-path?
         pin-line pin-arrow-line pin-arrows-line
         (contract-out
          [freeze (->* (pict-convertible?)
                       (#:inset (or/c real?
                                      (list/c real?)
                                      (list/c real? real?)
                                      (list/c real? real? real? real?))
                        #:scale real?)
                       pict?)])


         dc-for-text-size
         convert-bounds-padding
         show-pict
         current-expected-text-scale
         dc
         linewidth
         linestyle

         draw-pict
         make-pict-drawer

         (contract-out
          [text (->* (string?)
                     (text-style/c 
                      (and/c (between/c 1 1024) integer?)
                      number?)
                     pict?)])

         text-style/c

         (struct-out pict)
         (struct-out child)

         black-and-white

         lt-find
         lc-find
         lb-find
         ltl-find
         lbl-find
         ct-find
         cc-find
         cb-find
         ctl-find
         cbl-find
         rt-find
         rc-find
         rb-find
         rtl-find
         rbl-find


         launder  ; pict -> pict

         blank        ; -> pict
         ;; w h -> pict
         ;; w h d -> pict

         clip-descent   ; pict -> pict
         clip-ascent    ; pict -> pict
         baseless       ; pict -> pict
         inset          ; pict i -> pict
         ; pict hi vi -> pict
         ; pict l t r b -> pict
         refocus        ; pict pict -> pict
         panorama       ; pict -> pict

         use-last       ; pict pict -> pict
         use-last*      ; pict pict -> pict

         hline        ; w h -> pict
         vline        ; w h -> pict
         
         frame        ; pict -> pict
         
         
         
         ghost        ; pict -> pict

         
         vl-append    ; d pict ... -> pict ; d units between each picture
         vc-append
         vr-append
         ht-append
         hc-append
         hb-append
         htl-append       ; align bottoms of ascents
         hbl-append       ; align tops of descents (normal text alignment)

         lt-superimpose ; pict ... -> pict
         lb-superimpose
         lc-superimpose
         ltl-superimpose
         lbl-superimpose
         rt-superimpose
         rb-superimpose
         rc-superimpose
         rtl-superimpose
         rbl-superimpose
         ct-superimpose
         cb-superimpose
         cc-superimpose
         ctl-superimpose
         cbl-superimpose

         table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict

         colorize ; pict color-string -> pict

         pin-over
         pin-under
         drop-below-ascent
         lift-above-baseline

         (except-out (all-from-out "utils.rkt")
                   
                     color-frame color-dash-frame
                     round-frame color-round-frame
    
                     cons-colorized-picture
                     arrow-line
                     arrows-line

                     add-line
                     add-arrow-line
                     add-arrows-line

                     explode-star

                     cloud
                     file-icon
                     standard-fish
                     jack-o-lantern
                     angel-wing
                     desktop-machine
                     thermometer
                     cat-silhouette
                     standard-cat/transform
                     happy-eyes

                     find-pen find-brush)
         (contract-out
          [cloud (->* [real? real?]
                      [(or/c string? (is-a?/c color%))
                       #:style (listof (or/c 'square 'nw 'ne 'sw 'se 'wide))]
                      pict?)]
          [file-icon (->* [real? real? any/c] [any/c] pict?)]
          [rename fish standard-fish (->* [real? real?]
                                          [#:direction (or/c 'left 'right)
                                           #:color (or/c string? (is-a?/c color%))
                                           #:eye-color (or/c string? (is-a?/c color%) #f)
                                           #:open-mouth (or/c boolean? (between/c 0 1))]
                                          pict?)]
          [jack-o-lantern (->* [real?]
                               [(or/c string? (is-a?/c color%))
                                (or/c string? (is-a?/c color%))
                                (or/c string? (is-a?/c color%))]
                               pict?)]
          [angel-wing (-> real? real? any/c pict?)]
          [desktop-machine (->* [real?] [(listof symbol?)] pict?)]
          [thermometer (->* []
                            [#:height-% (between/c 0 1)
                             #:color-% (between/c 0 1)
                             #:ticks exact-nonnegative-integer?
                             #:start-color (or/c string? (is-a?/c color%))
                             #:end-color (or/c string? (is-a?/c color%))
                             #:top-circle-diameter (>/c 0)
                             #:bottom-circle-diameter (>/c 0)
                             #:stem-height (>/c 0)
                             #:mercury-inset (>/c 0)]
                            pict?)])
         pict->bitmap
         pict->argb-pixels
         argb-pixels->pict)
