;;;
;;; MODEL
;;;

; Modellen består af et billede, hvorpå
; der kan tegnes.

(define bredde 500)
(define højde  500)

(define modelbitmap 
  (make-object bitmap% bredde højde #f))
(define modelbitmapsammenhæng
  (instantiate bitmap-dc% (modelbitmap)))

;;;
;;; CONTROLLER
;;;

(define (punkt start)
  (send modelbitmapsammenhæng set-pen pen)
  (send modelbitmapsammenhæng
        draw-point (first start) (second start)))

(define (linje start slut)
  (send modelbitmapsammenhæng set-pen pen)
  (send modelbitmapsammenhæng
        draw-line (first start) (second start) (first slut) (second slut)))

(define (firkant start slut)
  (send modelbitmapsammenhæng set-pen   gennemsigtig-pen)
  (send modelbitmapsammenhæng set-brush pensel)
  (let ([x1 (first  start)]
        [y1 (second start)]
        [x2 (first  slut)]
        [y2 (second slut)])
    (send modelbitmapsammenhæng
          draw-rectangle x1 y1 (abs (- x2 x1)) (abs (- y2 y1)))))

(define (rens)
  (send modelbitmapsammenhæng clear))

;;; Penne og pensler

; Pennen bruges til at tegne punkter og linjer
; Penslen bruges til at tegne indmaden af firkanter, cirkler m.m.,
; og pennen bruges så til kanterne

(define hvid (make-object color% "white"))
(define pen              (make-object pen%   hvid 2 'solid))
(define pensel           (make-object brush% hvid   'solid))
(define gennemsigtig-pen (make-object pen%   hvid 0 'transparent))

(define (farve navn)
  (define ny-farve 
    (if (symbol? navn)
        (make-object color% navn)
        navn))
  (set! pen    (make-object pen%   ny-farve 2 'solid))
  (set! pensel (make-object brush% ny-farve   'solid)))

;;;
;;; SYN (GUI)
;;;

; Synet har en kopi af modelbitmappen.
; dette bruges til at lave hjælpelinjer m.m.

(define synbitmap 
  (make-object bitmap% bredde højde #f))
(define synbitmapsammenhæng
  (instantiate bitmap-dc% (synbitmap)))

(define (kopier-modelbitmap-til-synbitmap)
  (send synbitmapsammenhæng
        draw-bitmap modelbitmap 0 0))

;;;
;;; Koordinater
;;;

; Den grafiske brugerflade holder styr på,
; hvor der trykkes på billedet.

(define start (list 0 0))
(define slut  (list 0 0))
(define nu    (list 0 0))

(define nedtrykket #f)

; Når musen nedtrykkes, huskes figurens startkoordinat.
(define (ned x y)
  (set! nedtrykket #t)
  (set! start (list x y)))

; Når musen slippes tegnes på modellen
(define (op x y)
  (set! nedtrykket #f)
  (set! slut (list x y))
  (case redskab
    [(linje)   (linje start slut)
               (kopier-modelbitmap-til-synbitmap)]
    [(firkant) (firkant start slut)
               (kopier-modelbitmap-til-synbitmap)]))

(define (bevæg x y)
  (set! nu (list x y))
  (case redskab
    [(punkt) (if nedtrykket 
                 (begin
                   (punkt nu)
                   (kopier-modelbitmap-til-synbitmap)
                   (opdater)))])
  (opdater-koordinater))

;;;
;;; Redskaber
;;; 

(define redskab 'linje)

;;;
;;; Muserelateret
;;; 

(define (behandl-musehændelse hændelse)
  (let ([hændelsestype (send hændelse get-event-type)]
        [x (send hændelse get-x)]
        [y (send hændelse get-y)])
    (case hændelsestype
      [(left-down)  (ned x y)]
      [(left-up)    (op x y) 
                    (opdater)]
      [(motion)     (bevæg x y)])))

;;
;; Opdater
;;

;; tegn eventuelle ændringer af synbitmappen på skærmen
(define (opdater)
  (opdater-koordinater)
  (send kanvas refresh))

(define (opdater-koordinater)
  (send startbesked set-label 
        (string-append "start: " (koordinater->string start)))
  (send slutbesked set-label 
        (string-append "slut: "  (koordinater->string slut)))
  (send nubesked set-label 
        (string-append "nu: " (koordinater->string nu))))

(define (koordinater->string liste)
  (string-append (number->string (first liste)) 
                 " "
                 (number->string (second liste))))

;;;
;;; GUI-klasser
;;;

;; Vi har brug at ændre kanvas-klassen, så 
;; vi selv får lov til at håndtere musehændelser.

(define billedkanvas%
  (class canvas%
    (inherit get-dc)
    (define/override (on-subwindow-event modtager hændelse)
      (behandl-musehændelse hændelse))
    (super-instantiate ())))

;; gentegn kaldes af kanvasen, hvergang den modtager on-paint
;; ( Vinduessystemet frembringer hændelsen on-paint, når kanvasen skal gentegnes )

(define (gentegn kanvas sammenhæng)
  ; kopier synbitmapen til kanvassen (på skærmen)
  (send sammenhæng draw-bitmap synbitmap 0 0))

;;;
;;; Opbygning
;;;

(define ramme         (make-object frame% "Doodle"))
(define vandretpanel  (make-object horizontal-panel% ramme))
(define lodretpanel   (make-object vertical-panel% vandretpanel))

(define punktknap       (instantiate button% () 
                          (label "Point") (parent lodretpanel) 
                          (callback (lambda (knap hændelse) 
                                      (set! redskab 'punkt))))) 

(define linjeknap      (instantiate button% () 
                         (label "Line") (parent lodretpanel) 
                         (callback (lambda (knap hændelse) 
                                     (set! redskab 'linje)))))

(define firkantknap    (instantiate button% () 
                         (label "Square") (parent lodretpanel) 
                         (callback (lambda (knap hændelse) 
                                     (set! redskab 'firkant)))))

(define rensknap      (instantiate button% () 
                         (label "Clear") (parent lodretpanel) 
                         (callback (lambda (knap hændelse) 
                                     (rens)
                                     (kopier-modelbitmap-til-synbitmap)
                                     (opdater)))))

(define farveknap      (instantiate button% () 
                        (label "Colour") (parent lodretpanel) 
                        (callback (lambda (knap hændelse) 
                                    (farve (get-color-from-user "Vælg penfarve" ramme #f '()))))))

(define hvidknap      (instantiate button% () 
                        (label "White") (parent lodretpanel) 
                        (callback (lambda (knap hændelse) 
                                    (farve "white")))))

(define sortknap      (instantiate button% () 
                        (label "Black") (parent lodretpanel) 
                        (callback (lambda (knap hændelse) 
                                    (farve "black")))))

(define rødknap       (instantiate button% () 
                        (label "Red") (parent lodretpanel) 
                        (callback (lambda (knap hændelse) 
                                    (farve "red"))))) 


(define kanvas        (instantiate billedkanvas% () 
                        (parent vandretpanel)  
                        (min-width bredde) (min-height højde)
                        (paint-callback gentegn)))

(define startbesked   (make-object message% "Start                " ramme))
(define slutbesked    (make-object message% "End                  " ramme))
(define nubesked      (make-object message% "Now                  " ramme))

(send ramme show #t)
(sleep/yield 1)