Annotation of /skeleton-edit/draw.lAnnotation of /skeleton-edit/draw.l
Parent Directory
| 
Revision Log
Revision: 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 |