#lang racket
(provide
 label-ulft label-urt label-llft label-lrt 
 label-top label-bot label-rt label-lft
 
 dot-label-urt dot-label-ulft dot-label-llft dot-label-lrt
 dot-label-top dot-label-bot dot-label-rt dot-label-lft
)
;;----------------------------------
(require "main.rkt")
(require (planet wcy/anaphora))
(define (label p1 off pic p2)
  (draw (aprogn pic (shift p2 it) (shift (op* -1 (p1 pic)) it) (shift off it))))
(define (label-offset px py)
  (op* '3bp (point px py)))
(define (label-ulft pic a-point)
  (label lrcorner (label-offset -0.7 +0.7) pic a-point)) 
(define (label-urt pic a-point)
  (label llcorner (label-offset +0.7 +0.7) pic a-point))
(define (label-llft pic a-point)
  (label urcorner (label-offset -0.7 -0.7) pic a-point))
(define (label-lrt pic a-point)
  (label ulcorner (label-offset +0.7 -0.7) pic a-point))
(define (label-top pic a-point)
  (label pic-bottom (label-offset 0 1) pic a-point))
(define (label-bot pic a-point)
  (label pic-top (label-offset 0 -1) pic a-point))
(define (label-rt pic a-point)
  (label pic-left (label-offset 1 0) pic a-point))
(define (label-lft pic a-point)
  (label pic-right (label-offset -1 0) pic a-point))
(define dotlabeldiam (make-parameter '3bp))
(define (dot-label f pic a-point)
  (f pic a-point)
  (draw a-point #:withpen (scale (dotlabeldiam) 'pencircle)))
(define (dot-label-urt pic a-point)
  (dot-label label-urt pic a-point))
(define (dot-label-ulft pic a-point)
  (dot-label label-ulft pic a-point))
(define (dot-label-llft pic a-point)
  (dot-label label-llft pic a-point))
(define (dot-label-lrt pic a-point)
  (dot-label label-lrt pic a-point))
(define (dot-label-top pic a-point)
  (dot-label label-top pic a-point))
(define (dot-label-bot pic a-point)
  (dot-label label-bot pic a-point))
(define (dot-label-rt pic a-point)
  (dot-label label-rt pic a-point))
(define (dot-label-lft pic a-point)
  (dot-label label-lft pic a-point))