(module arrow mzscheme
  (require (lib "mrpict.ss" "texpict")
           (lib "utils.ss" "texpict")
           (lib "mred.ss" "mred")
           (lib "class.ss"))
  
  (provide make-arrow-pict)

  (define ARROW-LINE-WIDTH 0.33)
  
  (define (make-arrow-pict sample-str curvy? font-family font-size)
    (let ([ans #f])
      (λ ()
        (or ans
            (begin
              (set! ans
                    (let-values ([(w h d a) (send (dc-for-text-size) 
                                                  get-text-extent
                                                  sample-str
                                                  (send the-font-list
                                                        find-or-create-font
                                                        font-size
                                                        font-family
                                                        'normal
                                                        'normal))])
                      (let* ([b (blank w (- h a d) d)]
                             [a-sz (/ (pict-height b) 2.5)])
                        (inset (let ([p (pin-arrow-line a-sz b
                                                        b (if curvy? 
                                                              (lambda (p sp)
                                                                (let-values ([(x y) (rc-find p sp)])
                                                                  (values (- x a-sz) y)))
                                                              lc-find)
                                                        b rc-find
                                                        ARROW-LINE-WIDTH)])
                                 (if curvy?
                                     (refocus
                                      (cc-superimpose
                                       (let ([p (new dc-path%)]
                                             [h (- h a)]
                                             [inc (/ (- w a-sz) 3)])
                                         (send p move-to 0 (/ h 2))
                                         (let ([y (- (/ h 2) (/ a-sz 2))])
                                           (send p curve-to 
                                                 0 (/ h 2)
                                                 (/ inc 2) y
                                                 inc y)
                                           (let ([y2 (+ (/ h 2) (/ a-sz 2))])
                                             (send p curve-to
                                                   (* 3/2 inc) y
                                                   (* 3/2 inc) y2
                                                   (* 2 inc) y2)
                                             (send p curve-to
                                                   (* 5/2 inc) y2
                                                   (* 5/2 inc) (/ h 2)
                                                   (* 3 inc) (/ h 2))))
                                         (linewidth ARROW-LINE-WIDTH
                                                    (dc (lambda (dc x y)
                                                          (let ([b (send dc get-brush)])
                                                            (send dc set-brush "black" 'transparent)
                                                            (send dc draw-path p x y)
                                                            (send dc set-brush b)))
                                                        w h)))
                                       p)
                                      p)
                                     p))
                               1 a 1 0))))
              ans))))))