;;; more-buttons.rkt (avec la souris)
;;; Racket 5.3.6
;;; PF2 Automne 2013

#lang racket/gui

; les variables globales

(define LCERCLES '())    ; la liste de tous les cercles (des objets)
(define NBCERCLES 0)     ; pour ne pas recalculer la longueur chaque fois...

; the-brush-list is created automagically as an instance of brush-list%

; un cercle est un objet de la classe cercle%

(define cercle%
  (class object%
    (init-field (x 0) (y 0) (r 0) (brush "black"))  
    (define/public (getX) x)
    (define/public (getY) y)
    (define/public (getR) r)
    (define/public (setX nx) (set! x nx))
    (define/public (setY ny) (set! y ny))
    (define/public (draw-with dc)
      (send dc set-brush (send the-brush-list find-or-create-brush brush 'solid))
      (send dc draw-ellipse (- x r) (- y r) (* 2 r) (* 2 r)))
    (super-new)
    (set! LCERCLES (append LCERCLES (list this)))   ; ajout en queue de liste ! VOIR NOTE A LA FIN !
    (set! NBCERCLES (add1 NBCERCLES))
    (send GAUGE set-value (+ 1 (send GAUGE get-value)))
    (when (>= NBCERCLES (send GAUGE get-range))
      (send BUTTON1 enable #f))
    (send CANVAS refresh)))

; GUI stuff

(define SIZE 300)          ; taille du canvas
(define V #f)              ; pour faire bouger les cercles...

(define FRAME 
  (new frame% 
       (label "More buttons...") 
       (stretchable-width #f) 
       (stretchable-height #f)))

(define HPANEL
  (new horizontal-panel% (parent FRAME)))

(define VPANEL 
  (new vertical-panel%  (parent HPANEL)))

(define MYCANVAS%         ; une sous-classe de canvas% qui redefinit la methode on-event
  (class canvas%
    (define (dans-cercle? x y xc yc rc)               ; private
      (< (+ (abs (- x xc)) (abs (- y yc))) rc))       ; en fait dans le losange ;-) c'est plus rapide...
    (define (cercle-proche x y L)                     ; private, retourne #f ou un cercle
      (if (null? L)
          #f
          (let ((c (car L)))
            (if (dans-cercle? x y (send c getX) (send c getY) (send c getR))
                c
                (cercle-proche x y (cdr L))))))       ; iteratif
    (define/override (on-event evt)                   ; <-------------- pour ecouter la souris !
      (case (send evt get-event-type) 
        ((left-down) (let ((x (send evt get-x)) (y (send evt get-y)))
                       (set! V (cercle-proche x y LCERCLES))))
        ((left-up) (set! V #f))
        (else (if V
                  (begin (send V setX (send evt get-x))
                         (send V setY (send evt get-y))
                         (send this on-paint))
                  (set! V #f)))))
    (super-new)))

(define CANVAS 
  (new MYCANVAS% 
       (parent HPANEL) 
       (style '(border))
       (min-width SIZE)
       (min-height SIZE)
       (paint-callback (lambda (c dc)
                         (send dc clear)
                         (for-each (lambda (cercle) (send cercle draw-with dc)) 
                                   LCERCLES)))))

(define GAUGE 
  (new gauge% (parent VPANEL) (label "nbPoints") (range 14)))

(define BUTTON1 
  (new button% (parent VPANEL) (label "New")
       (callback (lambda (b evt)
                   (let ((x (random SIZE)) 
                         (y (random SIZE))
                         (radius (send SLIDER get-value))
                         (n (send RADIO get-selection)))
                     (make-object cercle% x y radius (send RADIO get-item-label n)))))))    ; meditez !

(define BUTTON2 
  (new button% (parent VPANEL) (label "Clear")
       (callback (lambda (b evt)
                   (set! LCERCLES '())
                   (set! NBCERCLES 0)
                   (send (send CANVAS get-dc) clear)
                   (send GAUGE set-value 0)
                   (send BUTTON1 enable #t)))))

(define RADIO 
  (new radio-box% 
       (parent VPANEL) 
       (label "Local color")
       (choices '("white" "red" "blue" "black"))
       (callback (lambda (r evt)
                   (let* ((n (send r get-selection)) (color (send r get-item-label n)))
                     (send (send CANVAS get-dc) set-brush 
                           (send the-brush-list find-or-create-brush color 'solid))
                     (send CANVAS refresh))))))

(define SLIDER 
  (new slider% 
       (parent VPANEL) 
       (label "Point size") 
       (style '(vertical))
       (min-value 5) 
       (max-value 30) 
       (init-value 10)
       (callback (lambda (s evt)
                   (send CANVAS refresh)))))

(send FRAME show #t)

;;; NOTES : 
;;; a) l'ajout en queue de liste avec append est peu efficace si la liste grossit beaucoup.
;;; Il faudrait implementer des listes qui grossissent a gauche et a droite en O(1), un 
;;; grand classique des cours "Algo et Structures de Donnees"... Voir PCPS :-)
;;; b) L'ordre de superposition des objets (la "z-position" en graphisme) est conserve
;;;    lors d'un deplacement a la souris. Ceci peut etre sujet a discussion.
;;; c) J'ai fait une classe cercle% comme entrainement, mais une struct suffisait.
;;; "L'objet ca fait class !" :-) Mmmm