#lang racket/base
(require slideshow/pict
         "display.rkt"
         "constants.rkt")
(provide opacity-layer
         circle-pict
         rect-pict
         text-pict
         text-block-pict
         draw-line-onto
         make-stand-out
         at
         draw-stack-onto)

;;opacity-layer : float uint uint -> pict
(define (opacity-layer alpha w h)
  (cellophane (colorize (filled-rectangle w h)
                        "white")
              0.6))

;;circle-pict : string string uint [uint] -> pict
(define (circle-pict color stroke-color width #:stroke-width [stroke-width 1])
    (pin-over (colorize (filled-ellipse width width)
                        stroke-color)
              (* stroke-width 2)
              (* stroke-width 2)
              (colorize (filled-ellipse (- width (* stroke-width 4))
                                        (- width (* stroke-width 4)))
                        color)))

;;rect-pict : string string uint uint [uint] -> pict
(define (rect-pict color stroke-color width height #:stroke-width [stroke-width 1])
  (pin-over (colorize (filled-rectangle width height)
                      stroke-color)
            (* stroke-width 2)
            (* stroke-width 2)
            (colorize (filled-rectangle (- width (* stroke-width 4))
                                        (- height (* stroke-width 4)))
                      color)))

;;text-pict : string [string] -> pict
(define (text-pict t #:color [color "black"])
  (colorize (text t) color))

;;text-block-pict : string [string] [string] [uint] [float] [uint] [uint] -> pict
(define (text-block-pict t #:backcolor [backcolor "white"]
                         #:forecolor [forecolor "black"]
                         #:padding [padding 10]
                         #:opacity [opacity 1.0]
                         #:width [width 0]
                         #:height [height 0])
  (let* ([textp (colorize (text t) forecolor)]
         [padx2 (* padding 2)]
         [text-cont (pin-over (blank (+ (pict-width textp) padx2)
                                     (+ (pict-height textp) padx2))
                              padding
                              padding
                              textp)]
         [bg (cellophane (colorize (filled-rectangle (max width (pict-width text-cont))
                                                     (max height (pict-height text-cont)))
                                   backcolor)
                         opacity)])
    (lc-superimpose bg text-cont))) 

;;draw-line-onto : pict uint uint uint uint string -> pict
(define (draw-line-onto base
                        startx
                        starty
                        endx
                        endy
                        color
                        #:width [width 1]
                        #:with-arrow [with-arrow #f]
                        #:arrow-sz [arrow-sz 10]
                        #:style [style 'solid])
  (let ([dx (- endx startx)]
        [dy (- endy starty)]
        [line-f (if with-arrow pip-arrow-line pip-line)])
    (pin-over base
              startx
              starty
              (linewidth width
                         (linestyle style
                                    (colorize (line-f dx dy arrow-sz)
                                              color))))))

;;make-stand-out : pict -> pict
(define (make-stand-out pict)
  (scale pict 2))

(struct draw-at (x y p) #:transparent)

;;at : uint uint pict -> draw-at
(define (at x y p)
  (draw-at x y p))

;;draw-stack-onto : pict (listof pict) -> pict
(define (draw-stack-onto base . picts)
  (for/fold ([p base]) ([cur-p (in-list picts)])
    (cond
      [(pict? cur-p) (pin-over p 0 0 cur-p)]
      [(draw-at? cur-p) (pin-over p
                                  (draw-at-x cur-p)
                                  (draw-at-y cur-p)
                                  (draw-at-p cur-p))]
      [else (error 'draw-onto "Invalid argument in 'picts' list.")])))