<<>>
<<;;; ColorPaint.scheme>>
<<;;; Copyright Ó 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Michael Plass, March 5, 1991 0:13 am PST>>
    <<>>
(define (flush)
<<;; flushes any previous input>>
(when (viewer-input-ready?)
(viewer-read)
(flush))) 

(define (cpaint rgb-vec lst)
;; rgb-vec defines the color - '#(0 0 0) is black, '#(100 0 0) is red, etc.
;; lst is the picture to add to
(define x0 #f)
(define y0 #f)
(define head (cons '(#f #f) (append lst '())))
(define last '())
(define rgb (make-rgb-color-operator 100))

(define (paint-refresh)
(if (not (null? (cdr last))) 
(let ((x0 (caar last)) (y0 (cadar last)) (x1 (caadr last)) (y1 (cadadr last)))
(if x1
(mask-vector (if x0 x0 x1) (if x0 y0 y1) x1 y1)
(begin
(set-stroke-width (car y1))
(if (cadr y1) (set-color (make-constant-color (cadr y1) rgb)))
)
)
(set! last (cdr last))
(paint-refresh)
)
)
)

(define (buttondown x y shift)
(define stroke-width #f)
(case shift
((0) (set! stroke-width 5))    ; plain
((1) (set! stroke-width 10))    ; control
((2) (set! stroke-width 15))    ; shift
((3) (set! stroke-width 20))    ; control-shift
)
(set-cdr! last (list (list #f (list stroke-width rgb-vec)) (list x y)))
(paint-refresh))

(define (mouseto x y shift)
(set-cdr! last (list (list x y)))
(paint-refresh)
)

(set-stroke-end 'round)
(set! last head)
(flush)
(format #t "Right-click to stop painting.~%")
(paint-refresh)
(let loop ((event (viewer-read)))
(case (event-kind event)
((buttonup)
(if (eq? (event-button event) 'right)
(cdr head)
(loop (viewer-read))))
((mouseto)
(mouseto (event-x event)
      (event-y event)
   (event-shift event))
(loop (viewer-read)))
((buttondown)
(buttondown (event-x event) (event-y event) (event-shift event))
(loop (viewer-read)))
((destroyed)
(format #t "Viewer destroyed.")
(cdr head)
)
((erased)
(set! last head)
(paint-refresh)
(loop (viewer-read))
)
(else
(format #t "Unhandled event: ~S~%" event)
(loop (viewer-read))))))