[wadalabfont-kit] / lisp / tools / draw.l  

Annotation of /lisp/tools/draw.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; draw.l
3 :     ;;
4 :    
5 :     (defun draw-octagon-win (win x y x-radius y-radius (mode 'black))
6 :     (setq x (fix x) y (fix y) x-radius (fix x-radius) y-radius (fix y-radius))
7 :     (lets ((dx (// (* x-radius 3) 7)) ;; ------ 0
8 :     (dy (// (* y-radius 3) 7)) ;; / \
9 :     (x0 (+ x x-radius)) ;; / \ 1
10 :     (x1 (+ x dx)) ;; | |
11 :     (x2 (- x dx)) ;; | |
12 :     (x3 (- x x-radius)) ;; | |
13 :     (y0 (+ y y-radius)) ;; \ / 2
14 :     (y1 (+ y dy)) ;; \ /
15 :     (y2 (- y dy)) ;; ------ 3
16 :     (y3 (- y y-radius))) ;; 0 1 2 3
17 :     (draw-lines (get-winprop win 'save)
18 :     (selectq mode
19 :     (white (get-winprop win 'savewhitegc))
20 :     (black (get-winprop win 'saveblackgc))
21 :     (t (funcall err:argument-type mode)))
22 :     (list x0 y1
23 :     x1 y0
24 :     x2 y0
25 :     x3 y1
26 :     x3 y2
27 :     x2 y3
28 :     x1 y3
29 :     x0 y2
30 :     x0 y1))))
31 :    
32 :     (defun draw-circle-win (win x y r (mode 'black))
33 :     (setq x (fix x) y (fix y) r (fix r))
34 :     (draw-arc (get-winprop win 'save)
35 :     (selectq mode
36 :     (white (get-winprop win 'savewhitegc))
37 :     (black (get-winprop win 'saveblackgc))
38 :     (t (funcall err:argument-type mode)))
39 :     (- x r)
40 :     (- y r)
41 :     (+ r r)
42 :     (+ r r)
43 :     0 360))
44 :    
45 :     (defun draw-box-win (win x y x-radius y-radius (mode 'black))
46 :     (setq x (fix x) y (fix y) x-radius (fix x-radius) y-radius (fix y-radius))
47 :     (draw-rectangle (get-winprop win 'save)
48 :     (selectq mode
49 :     (white (get-winprop win 'savewhitegc))
50 :     (black (get-winprop win 'saveblackgc))
51 :     (t (funcall err:argument-type mode)))
52 :     (- x x-radius)
53 :     (- y y-radius)
54 :     (* 2 x-radius)
55 :     (* 2 y-radius)))
56 :    
57 :     (defun draw-ellipse-win (win x y x-radius y-radius (mode 'black))
58 :     (setq x (fix x) y (fix y) x-radius (fix x-radius) y-radius (fix y-radius))
59 :     (draw-arc (get-winprop win 'save)
60 :     (selectq mode
61 :     (white (get-winprop win 'savewhitegc))
62 :     (black (get-winprop win 'saveblackgc))
63 :     (t (funcall err:argument-type mode)))
64 :     (- x x-radius)
65 :     (- y y-radius)
66 :     (* 2 x-radius)
67 :     (* 2 y-radius)
68 :     0 360))
69 :    
70 :     (defun draw-line-win (win x0 y0 x1 y1 (mode 'black))
71 :     (setq x0 (fix x0) y0 (fix y0) x1 (fix x1) y1 (fix y1))
72 :     (draw-line (get-winprop win 'save)
73 :     (selectq mode
74 :     (white (get-winprop win 'savewhitegc))
75 :     (black (get-winprop win 'saveblackgc))
76 :     (t (funcall err:argument-type mode)))
77 :     x0 y0 x1 y1))
78 :    
79 :     (defun draw-sikaku-win (win x y (mode 'black))
80 :     (setq x (fix x) y (fix y))
81 :     (draw-rectangle (get-winprop win 'save)
82 :     (selectq mode
83 :     (white (get-winprop win 'savewhitegc))
84 :     (black (get-winprop win 'saveblackgc))
85 :     (t (funcall err:argument-type mode)))
86 :     (- x 2) (- y 2)
87 :     4 4)))
88 :    
89 :     (defun draw-sankaku-win (win x y (mode 'black))
90 :     (setq x (fix x) y (fix y))
91 :     (draw-lines (get-winprop win 'save)
92 :     (selectq mode
93 :     (white (get-winprop win 'savewhitegc))
94 :     (black (get-winprop win 'saveblackgc))
95 :     (t (funcall err:argument-type mode)))
96 :     (list x (- y 3)
97 :     (- x 3) (+ y 2)
98 :     (+ x 3) (+ y 2)
99 :     x (- y 3))))
100 :    
101 :     (defun beep (win)
102 :     (lets ((disp (window-display win))
103 :     (high (get-winprop win 'highlighten))
104 :     (low (selectq high
105 :     (yes 'no)
106 :     (no 'yes))))
107 :     (put-winprop win 'highlighten low)
108 :     (redraw-win win)
109 :     (display-force-output disp)
110 :     (put-winprop win 'highlighten high)
111 :     (redraw-win win)
112 :     (bell disp)
113 :     (display-force-output disp)))
114 :    
115 :     (defun cons2flat (points)
116 :     (mapcon points
117 :     (function (lambda (l) (list (caar l) (cdar l))))))
118 :    
119 :     (defun fill-polygon-win! (win points (mode 'black))
120 :     (draw-lines win
121 :     (selectq mode
122 :     (white (get-winprop win 'whitegc))
123 :     (black (get-winprop win 'blackgc))
124 :     (xor (get-winprop win 'xorgc))
125 :     (t (funcall err:argument-type mode)))
126 :     (cons2flat points)
127 :     :fill-p t))
128 :     (defun show-polygon-win! (win points (mode 'black))
129 :     (draw-lines win
130 :     (selectq mode
131 :     (white (get-winprop win 'whitegc))
132 :     (black (get-winprop win 'blackgc))
133 :     (xor (get-winprop win 'xorgc))
134 :     (t (funcall err:argument-type mode)))
135 :     (cons2flat points)))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help