(define (flush)
(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))))))

    ª  
;;; ColorPaint.scheme
;;; Copyright Ó 1991 by Xerox Corporation.  All rights reserved.
;;; Michael Plass, March 5, 1991 0:13 am PST

;; flushes any previous input
Ê)  –(cedarcode) style•NewlineDelimiter
™ default™KšœÐetœ1™@K™,Icode™ —˜Kšœ™šœ˜Kšœ˜Kšœ
˜
—K˜ —šœ˜KšœK˜KKšœ˜Kšœ˜Kšœ˜Kšœ.˜.K˜Kšœ*˜*K˜ ˜˜šœN˜N˜Kšœ/˜/˜Kšœ˜Kšœ>˜>K˜—K˜—K˜K˜Kšœ˜—K˜—K˜K˜ —šœ˜Kšœ˜šœ˜KšœÏc˜#Kšœž	˜&Kšœž˜$Kšœž˜,K˜—KšœG˜GKšœ˜—K˜ šœ˜K˜!K˜Kšœ˜—K˜ Kšœ˜K˜Kšœ˜K˜-K˜šœ!˜!šœ˜šœ˜šœ%˜%K˜
Kšœ˜——šœ
˜
šœ˜šœ˜Kšœ˜——Kšœ˜—šœ˜Kšœ@˜@Kšœ˜—˜K˜K˜
K˜—˜	K˜K˜Kšœ˜K˜—šœ˜Kšœ)˜)Kšœ˜————J˜ — …—    Ê  	  