home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / apteryx / face.lsp < prev    next >
Lisp/Scheme  |  1994-05-31  |  5KB  |  155 lines
  1. ; To see a picture of a face, execute menu option
  2. ; Lisp:Load Buffer
  3.  
  4. ;;; general functions
  5.  
  6. ; initial position of window
  7. (setq *show-rect* (rect (point 185 125) (point 540 470)))
  8.  
  9. ; Find a sub-rectangle treating original rectangle
  10. ; as a 1.0 * 1.0 unit box with origin at top left
  11. (defun sub-rect (rect left top right bottom)
  12.   (let ( (l (rect-left rect))
  13.          (w (rect-width rect))
  14.          (tp (rect-top rect))
  15.          (h (rect-height rect)) )
  16.     (rect
  17.       (point (+ l (* left w)) (+ tp (* top h)))
  18.       (point (+ l (* right w)) (+ tp (* bottom h))) ) ) )
  19.  
  20. ; macro to show graphic drawn in an expression where rect
  21. ; is a variable equal to the window's client rectangle
  22. (defmacro show (draw-in-rect &key (title "Window") )
  23.   `(progn       
  24.      (setq *show-window*
  25.        (make-window ,title 
  26.          :painter #'(lambda (wind repaint-rect)
  27.                       (let ( (rect (sub-rect (client-rect wind)
  28.                                      0.05 0.05 0.95 0.95) ) )
  29.                         ,draw-in-rect) )
  30.          :rect *show-rect*) ) ) )
  31.  
  32. ; example using show macro to draw an ellipse
  33. ; (show (draw-ellipse rect))
  34.  
  35. ; Find centre of a rectangle
  36. (defun rect-centre (rect)
  37.   (point
  38.     (+ (rect-left rect) (/ (rect-width rect) 2))
  39.     (+ (rect-top rect) (/ (rect-height rect) 2)) ) )
  40.  
  41. ; Create rectangle with given centre, width and height
  42. (defun rect-with-centre (centre width height)
  43.   (let ( (centre-x (point-x centre))
  44.          (centre-y (point-y centre))
  45.          (w2 (/ width 2))
  46.          (h2 (/ height 2)) )
  47.     (rect
  48.       (point (- centre-x w2) (- centre-y h2))
  49.       (point (+ centre-x w2) (+ centre-y h2)) ) ) )
  50.  
  51. (setq *draw-sub-rects* nil)
  52.  
  53. ;;; eyes
  54.  
  55. ; Draw an eye with iris at specified position
  56. (defun draw-eye (rect &key (oclock 6))
  57.   (if *draw-sub-rects* (draw-focus-rect rect))
  58.   (let* ( (angle (* (/ pi 6.0) (- 6 oclock)))
  59.           (eye-width (rect-width rect))
  60.           (eye-height (rect-height rect))
  61.           (eye-centre (rect-centre rect))
  62.           (pupil-centre
  63.             (point
  64.               (+ (point-x eye-centre) (* 0.25 eye-width (sin angle)))
  65.               (+ (point-y eye-centre) (* 0.25 eye-height (cos angle))) ) )
  66.           (pupil-rect
  67.             (rect-with-centre pupil-centre
  68.               (/ eye-width 2) (/ eye-height 2) ) ) )
  69.     (draw-ellipse rect)
  70.     (with-select (black_brush)
  71.       (draw-ellipse pupil-rect) ) ) )
  72.  
  73. ; (show (draw-eye rect :oclock 7))
  74.  
  75. ; Find a point in a rectangle treating original rectangle
  76. ; as a 1.0 * 1.0 unit box with origin at top left
  77. (defun rect-point (rect x y)
  78.   (let ( (l (rect-left rect))
  79.          (w (rect-width rect))
  80.          (tp (rect-top rect))
  81.          (h (rect-height rect)) )
  82.     (point (+ l (* x w)) (+ tp (* y h))) ) )
  83.  
  84. ; Rectangle containing left eye as a function of rectangle
  85. ; enclosing face
  86. (defun left-eye-rect (face-rect)
  87.   (sub-rect face-rect 0.2 0.2 0.4 0.5) )
  88.  
  89. ; Rectangle containing right eye as a function of rectangle
  90. ; enclosing face
  91. (defun right-eye-rect (face-rect)
  92.   (sub-rect face-rect 0.6 0.2 0.8 0.5) )
  93.  
  94. ;;; nose
  95.  
  96. ; Draw a nose in a rectangle
  97. (defun draw-nose (rect)
  98.   (if *draw-sub-rects* (draw-focus-rect rect))
  99.   (move-to (rect-point rect 0.5 0.0))
  100.   (line-to (rect-point rect 0.0 1.0))
  101.   (line-to (rect-point rect 1.0 1.0)) )
  102.  
  103. ; (show (draw-nose rect))
  104.  
  105. ; Find rectangle containing nose as a function of rectangle
  106. ; containing face
  107. (defun nose-rect (face-rect)
  108.   (sub-rect face-rect 0.4 0.3 0.6 0.7) )
  109.  
  110. ;;; mouth
  111.  
  112. ; Draw a smiling mouth in a rectangle
  113. (defun draw-mouth (rect)
  114.   (if *draw-sub-rects* (draw-focus-rect rect))
  115.   (let ( (left-point (point (rect-left rect) (rect-top rect)))
  116.          (right-point  (point (rect-right rect) (rect-top rect))) )
  117.     (draw-arc
  118.       (sub-rect rect 0.0 -1.0 1.0 1.0)
  119.       left-point right-point) ) )
  120.  
  121. ; (show (draw-mouth rect))
  122.  
  123. ; Find rectangle containing mouth as a function of rectangle
  124. ; containing face
  125. (defun mouth-rect (face-rect)
  126.   (sub-rect face-rect 0.3 0.7 0.7 0.85) )
  127.  
  128. ;;; face
  129.  
  130. ; Choose a good line width relative to window size
  131. (defun good-line-width (rect)
  132.   (/ (min (rect-width rect) (rect-height rect)) 50) )
  133.  
  134. ; Draw a face in a rectangle
  135. (defun draw-face (rect &key (eye-oclock 7))
  136.   (let ( (line-pen (create-pen ps_Solid (good-line-width rect) black)) )
  137.     (with-select (line-pen)
  138.       (if *draw-sub-rects* (draw-focus-rect rect))
  139.       (draw-ellipse rect)
  140.       (draw-eye (left-eye-rect rect) :oclock eye-oclock)
  141.       (draw-eye (right-eye-rect rect) :oclock eye-oclock)
  142.       (draw-nose (nose-rect rect))
  143.       (draw-mouth (mouth-rect rect)) ) ) )
  144.  
  145. ; (setq *draw-sub-rects* nil)
  146. ; (setq *draw-sub-rects* t)
  147.  
  148. ; Make a window containing a face
  149. (show (draw-face rect :eye-oclock 8) :title "Face")
  150.  
  151. ; Print the face out on your printer
  152. ; (print-window *show-window*)
  153.  
  154.  
  155.