140 lines
4.0 KiB
Scheme
140 lines
4.0 KiB
Scheme
(module face-demo mzscheme
|
|
(require (lib "mred.ss" "mred")
|
|
(lib "class.ss")
|
|
(lib "utils.ss" "texpict")
|
|
(lib "mrpict.ss" "texpict")
|
|
(lib "face.ss" "texpict"))
|
|
|
|
(define f (new frame% (label "frame")))
|
|
|
|
(define canvas-scale 1)
|
|
|
|
(define c (new canvas%
|
|
(parent f)
|
|
(paint-callback
|
|
(lambda (x dc)
|
|
(send dc set-scale canvas-scale canvas-scale)
|
|
(cb dc)))))
|
|
|
|
|
|
(define moods
|
|
'(unhappiest
|
|
unhappier
|
|
unhappy
|
|
sortof-unhappy
|
|
sortof-happy
|
|
happy
|
|
happier
|
|
happiest
|
|
embarassed
|
|
badly-embarassed
|
|
mad
|
|
mean))
|
|
|
|
(new button%
|
|
(label "Face Color...")
|
|
(parent f)
|
|
(callback (lambda (b e)
|
|
(let ([c (get-color-from-user "Face Color" f face-color)])
|
|
(when c
|
|
(set! face-color c)
|
|
(new-face-callback))))))
|
|
(new choice%
|
|
(label #f)
|
|
(choices (append (map symbol->string moods) (list "Custom")))
|
|
(parent f)
|
|
(callback (lambda (c e)
|
|
(let ([v (send c get-selection)])
|
|
(set! face-mood (and (v . < . (length moods))
|
|
(list-ref moods v)))
|
|
(new-face-callback)))))
|
|
|
|
(define custom-panel (new group-box-panel% (label "Custom") (parent f)))
|
|
(let ([choices '(none normal worried angry raised)])
|
|
(new choice%
|
|
(label "Eyebrows")
|
|
(choices (map symbol->string choices))
|
|
(parent custom-panel)
|
|
(callback (lambda (c e)
|
|
(set! face-eyebrow-kind (list-ref choices (send c get-selection)))
|
|
(new-face-callback)))))
|
|
(let ([choices '(plain narrow medium large huge grimace)])
|
|
(new choice%
|
|
(label "Mouth")
|
|
(choices (map symbol->string choices))
|
|
(parent custom-panel)
|
|
(callback (lambda (c e)
|
|
(set! face-mouth-kind (list-ref choices (send c get-selection)))
|
|
(new-face-callback)))))
|
|
(new check-box%
|
|
(label "Frown")
|
|
(parent custom-panel)
|
|
(callback (lambda (c e)
|
|
(set! face-frown? (send c get-value))
|
|
(new-face-callback))))
|
|
(new slider%
|
|
(label "Eye Inset")
|
|
(parent custom-panel)
|
|
(min-value 0)
|
|
(max-value 10)
|
|
(callback (lambda (s e)
|
|
(set! face-eye-inset (send s get-value))
|
|
(new-face-callback))))
|
|
(new slider%
|
|
(label "Eyebrow Y")
|
|
(parent custom-panel)
|
|
(min-value -5)
|
|
(max-value 5)
|
|
(init-value 0)
|
|
(callback (lambda (s e)
|
|
(set! face-eyebrow-dy (send s get-value))
|
|
(new-face-callback))))
|
|
(let ([pupils
|
|
(lambda (label setter hi)
|
|
(new slider%
|
|
(label label)
|
|
(parent custom-panel)
|
|
(min-value (- hi))
|
|
(max-value hi)
|
|
(init-value 0)
|
|
(callback (lambda (s e)
|
|
(setter (send s get-value))
|
|
(new-face-callback)))))])
|
|
(pupils "Pupil X" (lambda (v) (set! face-pupils-dx v)) 10)
|
|
(pupils "Pupil Y" (lambda (v) (set! face-pupils-dy v)) 15))
|
|
|
|
|
|
(send custom-panel enable #f)
|
|
|
|
(dc-for-text-size (send c get-dc))
|
|
|
|
(define face-color default-face-color)
|
|
(define face-mood (car moods))
|
|
(define face-eyebrow-kind 'none)
|
|
(define face-mouth-kind 'plain)
|
|
(define face-frown? #f)
|
|
(define face-eye-inset 0)
|
|
(define face-eyebrow-dy 0)
|
|
(define face-pupils-dx 0)
|
|
(define face-pupils-dy 0)
|
|
|
|
(define the-pict (face face-mood face-color))
|
|
|
|
(define (new-face-callback)
|
|
(send custom-panel enable (not face-mood))
|
|
(set! the-pict (if face-mood
|
|
(face face-mood face-color)
|
|
(face* face-eyebrow-kind
|
|
face-mouth-kind face-frown?
|
|
face-color
|
|
face-eye-inset face-eyebrow-dy
|
|
face-pupils-dx face-pupils-dy)))
|
|
(send c on-paint))
|
|
|
|
(define (cb dc) (draw-pict the-pict dc 0 0))
|
|
|
|
(send c min-width (inexact->exact (floor (* canvas-scale (pict-width the-pict)))))
|
|
(send c min-height (inexact->exact (floor (* canvas-scale (pict-height the-pict)))))
|
|
|
|
(send f show #t))
|