#lang racket/gui
 
;;; api4.rkt - Editeur de polygones (page 329)
;;; Chapitre 14 (Objets et API graphique)
;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme"
;;; Langage determine par le source

(require lang/posn)

(define (build-polygon n f g)    ; n sommets de coordonnees <f(i),g(i)> pour i=0..n-1
  (do ((i n (- i 1)) (L '() (cons (make-posn (f i) (g i)) L)))
    ((= i 0) L)))

(define POLY (build-polygon 9 (lambda (i) (* 30 i)) (lambda (i) (random 300))))

(define PEN-FOR-LINES (make-object pen% "blue" 1 'solid))
(define PEN-FOR-POINTS (make-object pen% "red" 8 'solid))

(define (draw-polygon P dc)    ; P = (#(struct:posn x y) ...)
  (define (draw-vertices L)
    (send dc set-pen PEN-FOR-POINTS)
    (for-each (lambda (pt) (send dc draw-point (- (posn-x pt) 4) (- (posn-y pt) 4))) L))
  (define (draw-edges L)
    (send dc set-pen PEN-FOR-LINES)
    (do ((L L (cdr L)))
      ((null? (cdr L)) (void))
      (send dc draw-line (posn-x (car L)) (posn-y (car L)) (posn-x (cadr L)) (posn-y (cadr L)))))
  (send dc clear)
  (when (not (null? P))
    (draw-vertices P) (draw-edges P)))

(define (pt-proche x y L)
  (define (assez-proche? x1 y1 x2 y2)
    (< (+ (abs (- x1 x2)) (abs (- y1 y2))) 6))
  (if (null? L) 
      #f
      (let ((pt (car L)))
        (if (assez-proche? x y (posn-x pt) (posn-y pt))
            pt
            (pt-proche x y (cdr L))))))

(define V #f)   ; le point courant pour la souris

(define MY-CANVAS%         ; une sous-classe de canvas% qui redefinit la methode on-event
  (class canvas%
    (super-new)
    (define/override (on-event evt)
      (case (send evt get-event-type) 
        ((left-down) (let ((x (send evt get-x)) (y (send evt get-y)))
                       (set! V (pt-proche x y POLY))))
        ((left-up) (set! V #f))
        (else (when V (set-posn-x! V (send evt get-x)) 
                (set-posn-y! V (send evt get-y))
                (send this on-paint)))))))

(define FRAME (new frame%(label "Mouse Polygon") 
                   (stretchable-width #f) 
                   (stretchable-height #f)
                   (x 50)
                   (y 10)))

(define CANVAS (new MY-CANVAS% 
                    (parent FRAME)
                    (min-width 300) (min-height 300)
                    (paint-callback (lambda (obj dc)
                                      (draw-polygon POLY dc)))))


(send FRAME show #t)

(printf "Bougez les sommets a la souris, puis demandez au toplevel la valeur de POLY\n")