/collects/drracket/arrow.rkt

#lang racket/base

(require racket/class
         racket/math
         racket/gui/base)

(provide draw-arrow)

(define largest 16383)
(define smallest -16383)

(define arrow-head-angle (/ pi 8))
(define cos-arrow-head-angle (cos arrow-head-angle))
(define sin-arrow-head-angle (sin arrow-head-angle))

(define arrow-head-size 8)
(define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle))
(define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle))

(define arrow-root-radius 2.5)
(define arrow-root-diameter (* 2 arrow-root-radius))

; If alpha is the angle between the x axis and the Start->End vector:
;
; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle)
;      = end-x - arrow-head-size * cos(alpha - arrow-head-angle)
;      = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle))
;      = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha
;      = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha
;
; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle)
;      = end-y - arrow-head-size * sin(alpha - arrow-head-angle)
;      = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle))
;      = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha
;      = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha
;
; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle)
;      = end-x - arrow-head-size * cos(alpha + arrow-head-angle)
;      = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle))
;      = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha
;      = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha
;
; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle)
;      = end-y - arrow-head-size * sin(alpha + arrow-head-angle)
;      = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle))
;      = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha
;      = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha

; dc<%> real real real real real real -> void
; draw one arrow
; The reason of the "-0.5" in the definition of start-x and end-x in the let
; right below is because, well, after numerous experiments done under carefully
; controlled conditions by a team of independent experts, it was thought to
; be The Right Thing for the arrows to be drawn correctly, maybe.
(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
  (let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
        [uncropped-start-y (+ uncropped-pre-start-y dy)]
        [uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
        [uncropped-end-y (+ uncropped-pre-end-y dy)]
        [old-smoothed (send dc get-smoothing)])
    (let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
                  [(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
      (send dc set-smoothing 'aligned)
      (send dc draw-line start-x start-y end-x end-y)
      (when (and (< smallest start-x largest)
                 (< smallest start-y largest))
        (send dc draw-ellipse 
              (- start-x arrow-root-radius) (- start-y arrow-root-radius)
              arrow-root-diameter arrow-root-diameter))
      (when (and (< smallest end-x largest)
                 (< smallest end-y largest))
        (unless (and (= start-x end-x) (= start-y end-y))
          (let* ([offset-x (- end-x start-x)]
                 [offset-y (- end-y start-y)]
                 [arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))]
                 [cos-alpha (/ offset-x arrow-length)]
                 [sin-alpha (/ offset-y arrow-length)]
                 [arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)]
                 [arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)]
                 [arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)]
                 [arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)]
                 ; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1
                 [pt1 (make-object point% end-x end-y)]
                 [pt2 (make-object point%
                        (- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha)
                        (+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))]
                 [pt3 (make-object point%
                        (+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha)
                        (- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))])
            (send dc draw-polygon (list pt1 pt2 pt3)))))
      (send dc set-smoothing old-smoothed))))

;; crop-to : number number number number -> (values number number)
;; returns x,y if they are in the range defined by largest and smallest
;; otherwise returns the coordinates on the line from x,y to ox,oy
;; that are closest to x,y and are in the range specified by
;; largest and smallest
(define (crop-to x y ox oy)
  (cond
    [(and (< smallest x largest) (< smallest y largest))
     (values x y)]
    [else
     (let* ([xy-pr (cons x y)]
            [left-i (find-intersection x y ox oy smallest smallest smallest largest)]
            [top-i (find-intersection x y ox oy smallest smallest largest smallest)]
            [right-i (find-intersection x y ox oy largest smallest largest largest)]
            [bottom-i (find-intersection x y ox oy smallest largest largest largest)]
            [d-top (and top-i (dist top-i xy-pr))]
            [d-bottom (and bottom-i (dist bottom-i xy-pr))]
            [d-left (and left-i (dist left-i xy-pr))]
            [d-right (and right-i (dist right-i xy-pr))])
       (cond
         [(smallest? d-top d-bottom d-left d-right)
          (values (car top-i) (cdr top-i))]
         [(smallest? d-bottom d-top d-left d-right)
          (values (car bottom-i) (cdr bottom-i))]
         [(smallest? d-left d-top d-bottom d-right)
          (values (car left-i) (cdr left-i))]
         [(smallest? d-right d-top d-bottom d-left)
          (values (car right-i) (cdr right-i))]
         [else 
          ;; uh oh... if this case happens, that's bad news...
          (values x y)]))]))

;; smallest? : (union #f number)^4 -> boolean
;; returns #t if can is less and o1, o2, and o3
;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them
(define (smallest? can o1 o2 o3)
  (and can
       (andmap (位 (x) (< can x))
               (filter (位 (x) x)
                       (list o1 o2 o3)))))


;; inside? : (union #f (cons number number)) -> (union #f (cons number number))
;; returns the original pair if the coordinates are between smallest and largest
;; and returns #f if the pair is #f or the coordinates are outside.
(define (inside? pr)
  (and pr
       (let ([x (car pr)]
             [y (cdr pr)])
         (if (and (< smallest x largest)
                  (< smallest y largest))
             pr
             #f))))

;; find-intersection : (number^2)^2 -> (union (cons number number) #f)
;; finds the intersection between the lines specified by
;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4)
(define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
  (cond
    [(and (= x1 x2) (= x3 x4))
     #f]
    [(and (= x1 x2) (not (= x3 x4)))
     (let* ([m2 (/ (- y3 y4) (- x3 x4))]
            [b2 (- y3 (* m2 x3))])
       (cons x1
             (+ (* m2 x1) b2)))]
    [(and (not (= x1 x2)) (= x3 x4))
     (let* ([m1 (/ (- y1 y2) (- x1 x2))]
            [b1 (- y1 (* m1 x1))])
       (cons x3
             (+ (* m1 x3) b1)))]
    [(and (not (= x1 x2)) (not (= x3 x4)))
     (let* ([m1 (/ (- y1 y2) (- x1 x2))]
            [b1 (- y1 (* m1 x1))]
            [m2 (/ (- y3 y4) (- x3 x4))]
            [b2 (- y3 (* m2 x3))])
       (if (= m1 m2)
           #f
           (let* ([x (/ (- b1 b2) (- m2 m1))]
                  [y (+ (* m1 x) b1)])
             (cons x y))))]))

;; dist : (cons number number) (cons number number) -> number
(define (dist p1 p2)
  (sqrt (+ (sqr (- (car p1) (car p2)))
           (sqr (- (cdr p1) (cdr p2))))))

;; localled defined test code.... :(
;; use module language to run tests
(define (tests)
  (and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f)
       (equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0))
       (equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0))
       (equal? (find-intersection 0 0 3 3 2 2 4 4) #f)
       (equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0))
       (equal? (smallest? 3 1 2 3) #f)
       (equal? (smallest? 0 1 2 3) #t)
       (equal? (smallest? 1 0 2 3) #f)
       (equal? (smallest? 1 0 #f 4) #f)
       (equal? (smallest? 1 #f #f 4) #t)
       (equal? (smallest? 1 #f #f #f) #t)
       (equal? (dist (cons 1 1) (cons 4 5)) 5)))