home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #1
/
monster.zip
/
monster
/
PROG_GEN
/
APTERY.ZIP
/
FRAC.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1994-01-11
|
2KB
|
71 lines
; Copyright 1993 Apteryx Lisp Ltd
; Execute "Lisp:Load Buffer" menu option on this file
; to see a fractions display
(defstruct fraction top bottom)
(setq f (make-fraction :top 24 :bottom 5))
(setq *fraction-font* (create-font "Times" 40))
(setq *top-pos* (point 20 20))
(setq *bottom-pos* (point 20 60))
(setq *line-pen* (create-pen ps_Solid 3 black))
(setq *box-thickness* 2)
(setq *box-pen* (create-pen ps_Solid *box-thickness* black))
(setq *start-line* (point 20 59))
(setq *end-line* (point 50 59))
(setq *box-brush* (create-solid-brush yellow))
(defun draw-box (n b &optional p)
(with-select (*box-pen*)
(let* ( (left (+ (* 70 n) 100))
(right (+ left 40))
(height 200)
(section-height (/ height b))
(top 20) brush)
(dotimes (i b)
(setq brush (if (or (not p) (<= (- b i) p))
*box-brush* White_Brush))
(with-select (brush)
(draw-rect (rect
(point left (+ top (* section-height i)))
(point right (+ *box-thickness* top (* section-height (1+ i)))) ) ) ) ) ) ) )
(defun paint-fraction (w rect)
(with-struct ( fraction (window-data w))
(let ( (top-string (prin1-to-string top))
(bottom-string (prin1-to-string bottom)) )
(with-select (*fraction-font* *line-pen* *box-brush*)
(textout top-string *top-pos*)
(textout bottom-string *bottom-pos*)
(move-to *start-line*)
(line-to *end-line*) ) )
(let ( (num-whole-boxes (/ top bottom))
(remainder (rem top bottom)) )
(dotimes (i num-whole-boxes)
(draw-box i bottom) )
(if (> remainder 0)
(draw-box num-whole-boxes bottom remainder) ) ) ) )
; (progn (setf (window-painter w) #'paint-fraction) (repaint w))
(setq w (make-window "Fraction"
:data f
:painter #'paint-fraction
:rect (rect (point 40 160) (point 600 460)) ) )
; (window-rect w)
(defun reset-window-frac (w t b)
(bring-window-to-top w)
(setf (window-data w) (make-fraction :top t :bottom b))
(repaint w) )
; edit and re-eval this line to change fraction
(reset-window-frac w 24 7)
; eval next command to print out the window
; (print-window w)