View of /lisp/tools/draw.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; draw.l
;;

(defun draw-octagon-win (win x y x-radius y-radius (mode 'black))
  (setq x (fix x) y (fix y) x-radius (fix x-radius) y-radius (fix y-radius))
  (lets ((dx (// (* x-radius 3) 7)) ;;     ------    0
	 (dy (// (* y-radius 3) 7)) ;;    /      \
	 (x0 (+ x x-radius))        ;;   /        \  1
	 (x1 (+ x dx))              ;;   |        |
	 (x2 (- x dx))              ;;   |        |
	 (x3 (- x x-radius))        ;;   |        |
	 (y0 (+ y y-radius))        ;;   \        /  2
	 (y1 (+ y dy))              ;;    \      /
	 (y2 (- y dy))              ;;     ------    3 
	 (y3 (- y y-radius)))       ;;   0 1    2 3
    (draw-lines (get-winprop win 'save)
		(selectq mode
		  (white (get-winprop win 'savewhitegc))
		  (black (get-winprop win 'saveblackgc))
		  (t (funcall err:argument-type mode)))
		(list  x0 y1
		       x1 y0
		       x2 y0
		       x3 y1
		       x3 y2
		       x2 y3
		       x1 y3
		       x0 y2
		       x0 y1))))

(defun draw-circle-win (win x y r (mode 'black))
  (setq x (fix x) y (fix y) r (fix r))
  (draw-arc (get-winprop win 'save)
	    (selectq mode
	      (white (get-winprop win 'savewhitegc))
	      (black (get-winprop win 'saveblackgc))
	      (t (funcall err:argument-type mode)))
	    (- x r)
	    (- y r)
	    (+ r r)
	    (+ r r)
	    0 360))

(defun draw-box-win (win x y x-radius y-radius (mode 'black))
  (setq x (fix x) y (fix y) x-radius (fix x-radius) y-radius (fix y-radius))
  (draw-rectangle (get-winprop win 'save)
		  (selectq mode
		    (white (get-winprop win 'savewhitegc))
		    (black (get-winprop win 'saveblackgc))
		    (t (funcall err:argument-type mode)))
		  (- x x-radius)
		  (- y y-radius)
		  (* 2 x-radius)
		  (* 2 y-radius)))

(defun draw-ellipse-win (win x y x-radius y-radius (mode 'black))
  (setq x (fix x) y (fix y) x-radius (fix x-radius) y-radius (fix y-radius))
  (draw-arc (get-winprop win 'save)
	    (selectq mode
	      (white (get-winprop win 'savewhitegc))
	      (black (get-winprop win 'saveblackgc))
	      (t (funcall err:argument-type mode)))
	    (- x x-radius)
	    (- y y-radius)
	    (* 2 x-radius)
	    (* 2 y-radius)
	    0 360))

(defun draw-line-win (win x0 y0 x1 y1 (mode 'black))
  (setq x0 (fix x0) y0 (fix y0) x1 (fix x1) y1 (fix y1))
  (draw-line (get-winprop win 'save)
	     (selectq mode
	       (white (get-winprop win 'savewhitegc))
	       (black (get-winprop win 'saveblackgc))
	       (t (funcall err:argument-type mode)))
	     x0 y0 x1 y1))

(defun draw-sikaku-win (win x y (mode 'black))
  (setq x (fix x) y (fix y))
  (draw-rectangle (get-winprop win 'save) 
		  (selectq mode
		    (white (get-winprop win 'savewhitegc))
		    (black (get-winprop win 'saveblackgc))
		    (t (funcall err:argument-type mode)))
		  (- x 2) (- y 2)
		  4 4)))

(defun draw-sankaku-win (win x y (mode 'black))
  (setq x (fix x) y (fix y))
  (draw-lines (get-winprop win 'save) 
	      (selectq mode
		(white (get-winprop win 'savewhitegc))
		(black (get-winprop win 'saveblackgc))
		(t (funcall err:argument-type mode)))
	      (list x (- y 3)
		    (- x 3) (+ y 2)
		    (+ x 3) (+ y 2)
		    x (- y 3))))

(defun beep (win)
  (lets ((disp (window-display win))
	 (high (get-winprop win 'highlighten))
	 (low (selectq high
		(yes 'no)
		(no  'yes))))
    (put-winprop win 'highlighten low)
    (redraw-win win)
    (display-force-output disp)
    (put-winprop win 'highlighten high)
    (redraw-win win)
    (bell disp)
    (display-force-output disp)))

(defun cons2flat (points)
  (mapcon points
          (function (lambda (l) (list (caar l) (cdar l))))))

(defun fill-polygon-win! (win points (mode 'black))
  (draw-lines win
	      (selectq mode 
		(white (get-winprop win 'whitegc))
		(black (get-winprop win 'blackgc))
		(xor   (get-winprop win 'xorgc))
		(t     (funcall err:argument-type mode)))
	      (cons2flat points)
	      :fill-p t))
(defun show-polygon-win! (win points (mode 'black))
  (draw-lines win
	      (selectq mode 
		(white (get-winprop win 'whitegc))
		(black (get-winprop win 'blackgc))
		(xor   (get-winprop win 'xorgc))
		(t     (funcall err:argument-type mode)))
	      (cons2flat points)))