lib/triangle-button.rkt
#lang racket

(require racket/gui)

(require "date-utils.rkt")

(provide triangle%)

(define triangle%
  (class object%
    (super-new)

    (init-field
     name
     start-point-x
     start-point-y
     width
     height
     direction
     [down-border-color "black"]
     [down-fill-color "white"]
     [up-border-color "white"]
     [up-fill-color "black"])

    (define p1-x start-point-x)
    (define p1-y start-point-y)
    (define p2-x (+ start-point-x width))
    (define p2-y start-point-y)
    (define p3-x (+ start-point-x (ceiling (/ width 2))))
    (define p3-y #f)
    (if (eq? direction 'up)
        (set! p3-y (- start-point-y height))
        (set! p3-y (+ start-point-y height)))

    (define/private (get-ratio)
      (/ (/ width 2) height))

    (define/private (get-y x)
      (let* ([middle-x (+ start-point-x (/ width 2))]
             [compute-height
              (if (<= x middle-x) 
                  (* (- x start-point-x) (get-ratio))
                  (* (- (+ start-point-x width) x) (get-ratio)))])
        (if (eq? direction 'up)
            (- start-point-y compute-height)
            (+ start-point-y compute-height))))

    (define status 'leave)
    (define/public (set-status new-status)
      (set! status new-status))
    (define/public (get-status)
      status)

    (define/public (get-name)
      name)

    (define/public (draw dc)
      (let ([origin-pen (send dc get-pen)]
            [origin-brush (send dc get-brush)])
        (case status
          [(enter up)
           (begin
             (send dc set-pen up-border-color 1 'solid)
             (send dc set-brush up-fill-color 'solid))]
          [(down)
           (begin
             (send dc set-pen down-border-color 1 'solid)
             (send dc set-brush down-fill-color 'solid))]
          [else
           (begin
             (send dc set-pen down-border-color 1 'solid)
             (send dc set-brush down-fill-color 'solid))])

        (let ([triangle-path (new dc-path%)])
          (send triangle-path move-to p1-x p1-y)
          (send triangle-path line-to p2-x p2-y)
          (send triangle-path line-to p3-x p3-y)
          (send triangle-path close)
          (send dc draw-path triangle-path))

        (send dc set-pen origin-pen)
        (send dc set-brush origin-brush)))

    (define/public (point-in? point-x point-y)
      (if (and (>= point-x start-point-x) (<= point-x (+ start-point-x width)))
          (cond
           [(and (eq? direction 'up) (>= point-y (- start-point-y height)) (<= point-y start-point-y))
            (if (>= point-y (get-y point-x))
                #t
                #f)]
           [(and (eq? direction 'down) (<= point-y (+ start-point-y height)) (>= point-y start-point-y))
            (if (<= point-y (get-y point-x))
                #t
                #f)]
           [else
            #f])
          #f))))