home *** CD-ROM | disk | FTP | other *** search
/ CD Direkt 1995 #1 / Image.iso / cdd / winanw / aperyx / face.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-02-06  |  4.9 KB  |  159 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.          (t (rect-top rect))
  15.          (h (rect-height rect)) )
  16.     (rect
  17.       (point (+ l (* left w)) (+ t (* top h)))
  18.       (point (+ l (* right w)) (+ t (* 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.   (let ( (drawer-fun (gensym)) )
  24.     `(progn
  25.        (defun ,drawer-fun (wind repaint-rect)
  26.          (let ( (rect (sub-rect (client-rect wind)
  27.                         0.05 0.05 0.95 0.95) ) )
  28.            ,draw-in-rect) )
  29.        (setq *show-window*
  30.          (make-window ,title :painter #',drawer-fun
  31.            :rect *show-rect*) ) ) ) )
  32.  
  33. ; example using show macro to draw an ellipse
  34. ; (show (draw-ellipse rect))
  35.  
  36. ; Angles are in radians where pi radians = 180 degrees
  37. (defconstant pi 3.1415926535)
  38.  
  39. ; Find centre of a rectangle
  40. (defun rect-centre (rect)
  41.   (point
  42.     (+ (rect-left rect) (/ (rect-width rect) 2))
  43.     (+ (rect-top rect) (/ (rect-height rect) 2)) ) )
  44.  
  45. ; Create rectangle with given centre, width and height
  46. (defun rect-with-centre (centre width height)
  47.   (let ( (centre-x (point-x centre))
  48.          (centre-y (point-y centre))
  49.          (w2 (/ width 2))
  50.          (h2 (/ height 2)) )
  51.     (rect
  52.       (point (- centre-x w2) (- centre-y h2))
  53.       (point (+ centre-x w2) (+ centre-y h2)) ) ) )
  54.  
  55. (setq *draw-sub-rects* nil)
  56.  
  57. ;;; eyes
  58.  
  59. ; Draw an eye with iris at specified position
  60. (defun draw-eye (rect &key (oclock 6))
  61.   (if *draw-sub-rects* (draw-focus-rect rect))
  62.   (let* ( (angle (* (/ pi 6.0) (- 6 oclock)))
  63.           (eye-width (rect-width rect))
  64.           (eye-height (rect-height rect))
  65.           (eye-centre (rect-centre rect))
  66.           (pupil-centre
  67.             (point
  68.               (+ (point-x eye-centre) (* 0.25 eye-width (sin angle)))
  69.               (+ (point-y eye-centre) (* 0.25 eye-height (cos angle))) ) )
  70.           (pupil-rect
  71.             (rect-with-centre pupil-centre
  72.               (/ eye-width 2) (/ eye-height 2) ) ) )
  73.     (draw-ellipse rect)
  74.     (with-select (black_brush)
  75.       (draw-ellipse pupil-rect) ) ) )
  76.  
  77. ; (show (draw-eye rect :oclock 7))
  78.  
  79. ; Find a point in a rectangle treating original rectangle
  80. ; as a 1.0 * 1.0 unit box with origin at top left
  81. (defun rect-point (rect x y)
  82.   (let ( (l (rect-left rect))
  83.          (w (rect-width rect))
  84.          (t (rect-top rect))
  85.          (h (rect-height rect)) )
  86.     (point (+ l (* x w)) (+ t (* y h))) ) )
  87.  
  88. ; Rectangle containing left eye as a function of rectangle
  89. ; enclosing face
  90. (defun left-eye-rect (face-rect)
  91.   (sub-rect face-rect 0.2 0.2 0.4 0.5) )
  92.  
  93. ; Rectangle containing right eye as a function of rectangle
  94. ; enclosing face
  95. (defun right-eye-rect (face-rect)
  96.   (sub-rect face-rect 0.6 0.2 0.8 0.5) )
  97.  
  98. ;;; nose
  99.  
  100. ; Draw a nose in a rectangle
  101. (defun draw-nose (rect)
  102.   (if *draw-sub-rects* (draw-focus-rect rect))
  103.   (move-to (rect-point rect 0.5 0.0))
  104.   (line-to (rect-point rect 0.0 1.0))
  105.   (line-to (rect-point rect 1.0 1.0)) )
  106.  
  107. ; (show (draw-nose rect))
  108.  
  109. ; Find rectangle containing nose as a function of rectangle
  110. ; containing face
  111. (defun nose-rect (face-rect)
  112.   (sub-rect face-rect 0.4 0.3 0.6 0.7) )
  113.  
  114. ;;; mouth
  115.  
  116. ; Draw a smiling mouth in a rectangle
  117. (defun draw-mouth (rect)
  118.   (if *draw-sub-rects* (draw-focus-rect rect))
  119.   (let ( (left-point (point (rect-left rect) (rect-top rect)))
  120.          (right-point  (point (rect-right rect) (rect-top rect))) )
  121.     (draw-arc
  122.       (sub-rect rect 0.0 -1.0 1.0 1.0)
  123.       left-point right-point) ) )
  124.  
  125. ; (show (draw-mouth rect))
  126.  
  127. ; Find rectangle containing mouth as a function of rectangle
  128. ; containing face
  129. (defun mouth-rect (face-rect)
  130.   (sub-rect face-rect 0.3 0.7 0.7 0.85) )
  131.  
  132. ;;; face
  133.  
  134. ; Choose a good line width relative to window size
  135. (defun good-line-width (rect)
  136.   (/ (min (rect-width rect) (rect-height rect)) 50) )
  137.  
  138. ; Draw a face in a rectangle
  139. (defun draw-face (rect &key (eye-oclock 7))
  140.   (let ( (line-pen (create-pen ps_Solid (good-line-width rect) black)) )
  141.     (with-select (line-pen)
  142.       (if *draw-sub-rects* (draw-focus-rect rect))
  143.       (draw-ellipse rect)
  144.       (draw-eye (left-eye-rect rect) :oclock eye-oclock)
  145.       (draw-eye (right-eye-rect rect) :oclock eye-oclock)
  146.       (draw-nose (nose-rect rect))
  147.       (draw-mouth (mouth-rect rect)) ) ) )
  148.  
  149. ; (setq *draw-sub-rects* nil)
  150. ; (setq *draw-sub-rects* t)
  151.  
  152. ; Make a window containing a face
  153. (show (draw-face rect :eye-oclock 8) :title "Face")
  154.  
  155. ; Print the face out on your printer
  156. ; (print-window *show-window*)
  157.  
  158.  
  159.