#lang racket/gui ;;; more-buttons-no-mouse.rkt - L'exercice 14.5.7 page 339 ;;; Chapitre 14 (Objets et API graphique) ;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme" ;;; Langage determine par le source ; un cercle est une liste (x y rayon num-couleur) (define LCERCLES '()) (define NBCERCLES (length LCERCLES)) (define BRUSHES (list (make-object brush% "white" 'solid) (make-object brush% "red" 'solid) (make-object brush% "blue" 'solid) (make-object brush% "black" 'solid))) (define SIZE 300) ; taille du canvas (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 CANVAS (new canvas% (parent HPANEL) (style '(border)) (min-width SIZE) (min-height SIZE) (paint-callback (lambda (c dc) (send dc clear) (for-each (lambda (pt) (let ((x (car pt)) (y (cadr pt)) (r (caddr pt)) (nc (cadddr pt))) (send (send CANVAS get-dc) set-brush (list-ref BRUSHES nc)) (send dc draw-ellipse (- x r) (- y r) (* 2 r) (* 2 r)))) LCERCLES))))) (define GAUGE (new gauge% (parent VPANEL) (label "nbPoints") (range 14))) ; dans [0,14] ==> 15 points max ! (define BUTTON1 (new button% (parent VPANEL) (label "New") (callback (lambda (b evt) (let ((x (random SIZE)) (y (random SIZE)) (radius (send SLIDER get-value)) (num-color (send RADIO get-selection))) (set! LCERCLES (cons (list x y radius num-color) LCERCLES)) (set! NBCERCLES (+ NBCERCLES 1)) (send GAUGE set-value (+ 1 (send GAUGE get-value))) (when (= NBCERCLES (send GAUGE get-range)) (send b enable #f)) (send CANVAS refresh)))))) (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))) (send (send CANVAS get-dc) set-brush (list-ref BRUSHES n)) (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)