home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / apteryx / frac.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-04-14  |  2.3 KB  |  71 lines
  1. ; Copyright 1993 Apteryx Lisp Ltd
  2.  
  3. ; Execute "Lisp:Load Buffer" menu option on this file
  4. ; to see a fractions display
  5.  
  6. (defstruct fraction top bottom)
  7.  
  8. (setq f (make-fraction :top 24 :bottom 5))
  9.  
  10. (setq *fraction-font* (create-font "Times" 40))
  11.  
  12. (setq *top-pos* (point 20 20))
  13. (setq *bottom-pos* (point 20 60))
  14. (setq *line-pen* (create-pen ps_Solid 3 black))
  15. (setq *box-thickness* 2)
  16. (setq *box-pen* (create-pen ps_Solid *box-thickness* black))
  17. (setq *start-line* (point 20 59))
  18. (setq *end-line* (point 50 59))
  19. (setq *box-brush* (create-solid-brush yellow))
  20.  
  21. (defun draw-box (n b &optional p)
  22.   (with-select (*box-pen*)
  23.     (let* ( (left (+ (* 70 n) 100))
  24.             (right (+ left 40))
  25.             (height 200)
  26.             (section-height (/ height b))
  27.             (top 20) brush)
  28.       (dotimes (i b)
  29.         (setq brush (if (or (not p) (<= (- b i) p)) 
  30.                       *box-brush* White_Brush))
  31.         (with-select (brush)
  32.           (draw-rect (rect 
  33.                        (point left (+ top (* section-height i)))
  34.                        (point right (+ *box-thickness* top (* section-height (1+ i)))) ) ) ) ) ) ) )
  35.  
  36. (defun paint-fraction (w rect)
  37.   (with-struct ( fraction (window-data w)) 
  38.     (let ( (top-string (prin1-to-string top))
  39.            (bottom-string (prin1-to-string bottom)) )
  40.       (with-select (*fraction-font* *line-pen* *box-brush*)
  41.         (textout top-string *top-pos*)
  42.         (textout bottom-string *bottom-pos*)
  43.         (move-to *start-line*)
  44.         (line-to *end-line*) ) )
  45.     (let ( (num-whole-boxes (/ top bottom))
  46.            (remainder (rem top bottom)) )
  47.       (dotimes (i num-whole-boxes)
  48.         (draw-box i bottom) )
  49.       (if (> remainder 0)
  50.         (draw-box num-whole-boxes bottom remainder) ) ) ) ) 
  51.  
  52. ; (progn (setf (window-painter w) #'paint-fraction) (repaint w))
  53.  
  54. (setq w (make-window "Fraction"
  55.           :data f
  56.           :painter #'paint-fraction
  57.           :rect (rect (point 40 160) (point 600 460)) ) )
  58. ; (window-rect w)
  59.  
  60. (defun reset-window-frac (w tp b)
  61.   (bring-window-to-top w)
  62.   (setf (window-data w) (make-fraction :top tp :bottom b))
  63.   (repaint w) )
  64.  
  65. ; edit and re-eval this line to change fraction
  66. (reset-window-frac w 24 7)
  67.  
  68. ; eval next command to print out the window
  69. ; (print-window w)
  70.  
  71.