home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
lisp
/
interpre
/
apteryx
/
face.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1994-05-31
|
5KB
|
155 lines
; To see a picture of a face, execute menu option
; Lisp:Load Buffer
;;; general functions
; initial position of window
(setq *show-rect* (rect (point 185 125) (point 540 470)))
; Find a sub-rectangle treating original rectangle
; as a 1.0 * 1.0 unit box with origin at top left
(defun sub-rect (rect left top right bottom)
(let ( (l (rect-left rect))
(w (rect-width rect))
(tp (rect-top rect))
(h (rect-height rect)) )
(rect
(point (+ l (* left w)) (+ tp (* top h)))
(point (+ l (* right w)) (+ tp (* bottom h))) ) ) )
; macro to show graphic drawn in an expression where rect
; is a variable equal to the window's client rectangle
(defmacro show (draw-in-rect &key (title "Window") )
`(progn
(setq *show-window*
(make-window ,title
:painter #'(lambda (wind repaint-rect)
(let ( (rect (sub-rect (client-rect wind)
0.05 0.05 0.95 0.95) ) )
,draw-in-rect) )
:rect *show-rect*) ) ) )
; example using show macro to draw an ellipse
; (show (draw-ellipse rect))
; Find centre of a rectangle
(defun rect-centre (rect)
(point
(+ (rect-left rect) (/ (rect-width rect) 2))
(+ (rect-top rect) (/ (rect-height rect) 2)) ) )
; Create rectangle with given centre, width and height
(defun rect-with-centre (centre width height)
(let ( (centre-x (point-x centre))
(centre-y (point-y centre))
(w2 (/ width 2))
(h2 (/ height 2)) )
(rect
(point (- centre-x w2) (- centre-y h2))
(point (+ centre-x w2) (+ centre-y h2)) ) ) )
(setq *draw-sub-rects* nil)
;;; eyes
; Draw an eye with iris at specified position
(defun draw-eye (rect &key (oclock 6))
(if *draw-sub-rects* (draw-focus-rect rect))
(let* ( (angle (* (/ pi 6.0) (- 6 oclock)))
(eye-width (rect-width rect))
(eye-height (rect-height rect))
(eye-centre (rect-centre rect))
(pupil-centre
(point
(+ (point-x eye-centre) (* 0.25 eye-width (sin angle)))
(+ (point-y eye-centre) (* 0.25 eye-height (cos angle))) ) )
(pupil-rect
(rect-with-centre pupil-centre
(/ eye-width 2) (/ eye-height 2) ) ) )
(draw-ellipse rect)
(with-select (black_brush)
(draw-ellipse pupil-rect) ) ) )
; (show (draw-eye rect :oclock 7))
; Find a point in a rectangle treating original rectangle
; as a 1.0 * 1.0 unit box with origin at top left
(defun rect-point (rect x y)
(let ( (l (rect-left rect))
(w (rect-width rect))
(tp (rect-top rect))
(h (rect-height rect)) )
(point (+ l (* x w)) (+ tp (* y h))) ) )
; Rectangle containing left eye as a function of rectangle
; enclosing face
(defun left-eye-rect (face-rect)
(sub-rect face-rect 0.2 0.2 0.4 0.5) )
; Rectangle containing right eye as a function of rectangle
; enclosing face
(defun right-eye-rect (face-rect)
(sub-rect face-rect 0.6 0.2 0.8 0.5) )
;;; nose
; Draw a nose in a rectangle
(defun draw-nose (rect)
(if *draw-sub-rects* (draw-focus-rect rect))
(move-to (rect-point rect 0.5 0.0))
(line-to (rect-point rect 0.0 1.0))
(line-to (rect-point rect 1.0 1.0)) )
; (show (draw-nose rect))
; Find rectangle containing nose as a function of rectangle
; containing face
(defun nose-rect (face-rect)
(sub-rect face-rect 0.4 0.3 0.6 0.7) )
;;; mouth
; Draw a smiling mouth in a rectangle
(defun draw-mouth (rect)
(if *draw-sub-rects* (draw-focus-rect rect))
(let ( (left-point (point (rect-left rect) (rect-top rect)))
(right-point (point (rect-right rect) (rect-top rect))) )
(draw-arc
(sub-rect rect 0.0 -1.0 1.0 1.0)
left-point right-point) ) )
; (show (draw-mouth rect))
; Find rectangle containing mouth as a function of rectangle
; containing face
(defun mouth-rect (face-rect)
(sub-rect face-rect 0.3 0.7 0.7 0.85) )
;;; face
; Choose a good line width relative to window size
(defun good-line-width (rect)
(/ (min (rect-width rect) (rect-height rect)) 50) )
; Draw a face in a rectangle
(defun draw-face (rect &key (eye-oclock 7))
(let ( (line-pen (create-pen ps_Solid (good-line-width rect) black)) )
(with-select (line-pen)
(if *draw-sub-rects* (draw-focus-rect rect))
(draw-ellipse rect)
(draw-eye (left-eye-rect rect) :oclock eye-oclock)
(draw-eye (right-eye-rect rect) :oclock eye-oclock)
(draw-nose (nose-rect rect))
(draw-mouth (mouth-rect rect)) ) ) )
; (setq *draw-sub-rects* nil)
; (setq *draw-sub-rects* t)
; Make a window containing a face
(show (draw-face rect :eye-oclock 8) :title "Face")
; Print the face out on your printer
; (print-window *show-window*)