A very simple painting program

paint.rkt

#lang racket/gui

;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or
;;          [MIT license](http://opensource.org/licenses/MIT) at your option.

(require pict)

(define line-width-init 1)

(define my-canvas%
  (class canvas%
    (define color "black")
    (define line-width line-width-init)
    (define commands '())
    
    (define/override (on-event ev)
      (when (send ev get-left-down)
        (when (send ev button-changed? 'left)
          ; start a new line
          (set! commands (cons '() commands)))
        (define pos (cons (send ev get-x) (send ev get-y)))
        (set! commands (cons (cons pos (first commands)) (rest commands)))
        (send this refresh)))
    
    (define/public (get-commands)
      commands)

    (define/public (clear-commands)
      (set! commands '())
      (set-color color)
      (set-line-width line-width)
      (send this refresh))

    (define/public (set-color c)
      (set! color c)
      (set! commands
        (cons (list 'color color)
              (match commands
                [`((color ,c-old) . ,rst) rst] ; replace
                [else commands]))))

    (define/public (set-line-width w)
      (set! line-width w)
      (set! commands
        (cons (list 'line-width w) 
              (match commands
                [`((line-width ,w-old) . ,rst) rst] ; replace
                [else commands]))))

    (define/public (undo-command)
      (unless (empty? commands)
        (set! commands (rest commands))
        (send this refresh)))

    (super-new)
    (clear-commands)))

(define fr (new frame% [label "Racket Draw"]
                [width 500] [height 500]))

(define bt-panel (new horizontal-panel% [parent fr] [stretchable-height #f]))

(define bt-erase (new button% [parent bt-panel] [label "Clear"]
                      [callback (λ (bt ev) (send cv clear-commands))]))

(for ([color '("black" "red" "green" "blue")])
  (new button% [parent bt-panel] [label (pict->bitmap (colorize (filled-rectangle 20 20) color))]
       [callback (λ (bt ev) (send cv set-color color))]))
(define bt-color (new button% [parent bt-panel] [label "Color"]
                      [callback (λ (bt ev)
                                  (define c (get-color-from-user))
                                  (when c (send cv set-color c)))]))
(define bt-undo (new button% [parent bt-panel] [label "Undo"]
                      [callback (λ (bt ev)
                                  (send cv undo-command))]))

(define width-slider (new slider% [parent fr] [label "Line width"]
                          [min-value 1] [max-value 100] [init-value line-width-init]
                          [callback (λ (sl ev)
                                      (send cv set-line-width (send sl get-value)))]))

(define cv (new my-canvas% [parent fr]
                [paint-callback
                 (λ (cv dc)
                   (define commands (reverse (send cv get-commands)))
                   (send dc set-background "white")
                   (send dc clear)
                   ; Not efficient to redraw all the lines each time. We should keep the previous
                   ; picture and draw on top of it instead.
                   (for ([cmd (in-list commands)])
                     (match cmd
                       [`(line-width ,w)
                        (define p (send dc get-pen))
                        (send dc set-pen (send p get-color) w 'solid)
                        (send width-slider set-value w)]
                       [`(color ,c)
                        (define p (send dc get-pen))
                        (send dc set-pen c (send p get-width) 'solid)]
                       [(? list?)
                        (send dc draw-lines cmd)])))]))

(send fr show #t)