#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))))