1;;; envelope editor based on xm module (cf enved.scm) 2;;; 3;;; (xe-create-enved name parent args axis-bounds) -> new envelope editor (returned value is list) 4;;; (xe-envelope editor) -> current envelope (settable) 5 6(provide 'snd-xm-enved.scm) 7 8(if (and (provided? 'snd-motif) 9 (not (provided? 'snd-snd-motif.scm))) 10 (load "snd-motif.scm")) 11 12(define xe-envelope 13 (dilambda 14 (lambda (editor) 15 (or (car editor) 16 (map (editor 3) '(0 1 2 3)))) ; bounds 17 (lambda (editor new-env) 18 (set! (editor 0) new-env) 19 (xe-redraw editor)))) 20 21(define xe-create-enved 22 (let ((xe-ungrfy (lambda (editor y) 23 (let ((bounds (editor 3)) 24 (locs (editor 2))) 25 (let ((ay0 (bounds 1)) 26 (ay1 (bounds 3)) 27 (py0 (locs 1)) 28 (py1 (locs 3))) 29 (if (= py0 py1) 30 ay1 31 (min ay1 32 (max ay0 33 (+ ay0 (* (- ay1 ay0) 34 (/ (- py0 y) 35 (- py0 py1))))))))))) 36 (xe-ungrfx (lambda (editor x) 37 (let ((bounds (editor 3)) 38 (locs (editor 2))) 39 (let ((ax0 (bounds 0)) 40 (ax1 (bounds 2)) 41 (px0 (locs 0)) 42 (px1 (locs 2))) 43 (if (= px0 px1) 44 ax0 45 (min ax1 46 (max ax0 47 (+ ax0 (* (- ax1 ax0) 48 (/ (- x px0) 49 (- px1 px0)))))))))))) 50 (lambda (name parent args axis-bounds) 51 (let ((xe-mouse-down 0) 52 (xe-mouse-pos 0) 53 (xe-mouse-new #f)) 54 55 (define xe-mouse-press 56 (letrec ((xe-envelope-position 57 (lambda (x cur-env) 58 (do ((e cur-env (cddr e)) 59 (pos 0 (+ pos 2))) 60 ((= (car e) x) pos)))) 61 62 (xe-on-dot? 63 (let ((xe-mouse-radius .03)) 64 (lambda (x y cur-env pos) 65 (and (pair? cur-env) 66 (pair? (cdr cur-env)) 67 (or (and (< (abs (- (car cur-env) x)) xe-mouse-radius) 68 (< (abs (- (cadr cur-env) y)) xe-mouse-radius) 69 pos) 70 (xe-on-dot? x y (cddr cur-env) (+ pos 2))))))) 71 72 (xe-add-envelope-point 73 (lambda (x y cur-env) 74 (let ((new-env ())) 75 (let search-point ((e cur-env)) 76 (cond ((null? e) (append new-env (list x y))) 77 ((= (car e) x) (append new-env (list x y) (cddr e))) 78 ((> (car e) x) (append new-env (list x y) e)) 79 (else 80 (set! new-env (append new-env (list (car e) (cadr e)))) 81 (search-point (cddr e))))))))) 82 (lambda (editor xx yy) 83 (let* ((cur-env (xe-envelope editor)) 84 (x (xe-ungrfx editor xx)) 85 (y (xe-ungrfy editor yy)) 86 (pos (xe-on-dot? x y cur-env 0))) 87 (set! xe-mouse-new (not pos)) 88 (set! xe-mouse-down (get-internal-real-time)) 89 (if pos 90 (set! xe-mouse-pos pos) 91 (begin 92 (set! (xe-envelope editor) (xe-add-envelope-point x y cur-env)) 93 (set! xe-mouse-pos (xe-envelope-position x (xe-envelope editor))))))))) 94 95 96 (define xe-mouse-drag 97 (let ((xe-edit-envelope-point 98 (lambda (pos x y cur-env) 99 (do ((new-env ()) 100 (e cur-env (cddr e)) 101 (npos 0 (+ npos 2))) 102 ((= npos pos) 103 (append new-env (list x y) (cddr e))) 104 (set! new-env (append new-env (list (car e) (cadr e)))))))) 105 (lambda (editor xx yy) 106 ;; point exists, needs to be edited with check for various bounds 107 (let* ((cur-env (xe-envelope editor)) 108 (x (xe-ungrfx editor xx)) 109 (y (xe-ungrfy editor yy)) 110 (lx (if (= xe-mouse-pos 0) 111 (car cur-env) 112 (if (>= xe-mouse-pos (- (length cur-env) 2)) 113 (cur-env (- (length cur-env) 2)) 114 (max (cur-env (- xe-mouse-pos 2)) 115 (min x (cur-env (+ xe-mouse-pos 2)))))))) 116 (set! (xe-envelope editor) 117 (xe-edit-envelope-point xe-mouse-pos lx y cur-env)) 118 (xe-redraw editor))))) 119 120 121 (define xe-mouse-release 122 (let ((xe-click-time .1) 123 (xe-mouse-up 0) 124 (xe-remove-envelope-point 125 (lambda (pos cur-env) 126 (let ((new-env ())) 127 (let search-point ((e cur-env) 128 (npos 0)) 129 (if (null? e) 130 new-env 131 (if (= pos npos) 132 (append new-env (cddr e)) 133 (begin 134 (set! new-env (append new-env (list (car e) (cadr e)))) 135 (search-point (cddr e) (+ npos 2)))))))))) 136 (lambda (editor) 137 (let ((cur-env (xe-envelope editor))) 138 (set! xe-mouse-up (get-internal-real-time)) 139 (if (not (or xe-mouse-new 140 (> (- xe-mouse-up xe-mouse-down) xe-click-time) 141 (= xe-mouse-pos 0) 142 (>= xe-mouse-pos (- (length cur-env) 2)))) 143 (set! (xe-envelope editor) 144 (xe-remove-envelope-point xe-mouse-pos cur-env)))) 145 (xe-redraw editor) 146 (set! xe-mouse-new #f)))) 147 148 (with-let (sublet *motif* 149 'args args 'parent parent 'axis-bounds axis-bounds 'name name 150 'xe-redraw xe-redraw 'xe-mouse-press xe-mouse-press 'xe-mouse-drag xe-mouse-drag 'xe-mouse-release xe-mouse-release) 151 (if (not (member XmNbackground args)) 152 (set! args (append args (list XmNbackground *graph-color*)))) 153 (if (not (member XmNforeground args)) 154 (set! args (append args (list XmNforeground *data-color*)))) 155 (let* ((drawer (XtCreateManagedWidget name xmDrawingAreaWidgetClass parent args)) 156 (gc (car (snd-gcs))) 157 (arrow-cursor (XCreateFontCursor (XtDisplay (cadr (main-widgets))) XC_crosshair)) 158 (editor (let ((x0 (car axis-bounds)) 159 (x1 (cadr axis-bounds)) ; too confusing! -- change internally below 160 (y0 (caddr axis-bounds)) 161 (y1 (cadddr axis-bounds))) 162 (list (list x0 y0 x1 y0) ; needs to be in user-coordinates (graph size can change) 163 drawer 164 #f ; axis pixel locs filled in when drawn 165 (list x0 y0 x1 y1) 166 (list gc #f) 167 name)))) 168 (XtAddCallback drawer XmNresizeCallback 169 (lambda (w context info) 170 (set! (editor 2) (apply draw-axes drawer gc name axis-bounds)) 171 (xe-redraw editor))) 172 (XtAddCallback drawer XmNexposeCallback 173 (lambda (w context info) 174 (set! (editor 2) (apply draw-axes drawer gc name axis-bounds)) 175 (xe-redraw editor))) 176 (XtAddEventHandler drawer ButtonPressMask #f 177 (lambda (w context ev flag) 178 (xe-mouse-press editor (.x ev) (.y ev)))) 179 (XtAddEventHandler drawer ButtonMotionMask #f 180 (lambda (w context ev flag) 181 (xe-mouse-drag editor (.x ev) (.y ev)))) 182 (XtAddEventHandler drawer ButtonReleaseMask #f 183 (lambda (w context ev flag) 184 (xe-mouse-release editor))) 185 (XtAddEventHandler drawer EnterWindowMask #f 186 (lambda (w context ev flag) 187 (XDefineCursor (XtDisplay w) (XtWindow w) arrow-cursor))) 188 (XtAddEventHandler drawer LeaveWindowMask #f 189 (lambda (w context ev flag) 190 (XUndefineCursor (XtDisplay w) (XtWindow w)))) 191 editor)))))) 192 193 194(define (xe-redraw editor) 195 (let* ((cur-env (xe-envelope editor)) 196 (widget (editor 1)) 197 (dpy ((*motif* 'XtDisplay) widget)) 198 (wn ((*motif* 'XtWindow) widget)) 199 (ax-pix (editor 2)) 200 (ax-inf (editor 3)) 201 (gc (car (editor 4))) 202 (name (editor 5)) 203 (cr (and (>= (length editor) 7) (editor 6)))) 204 (when (and (list? ax-pix) 205 (list? cur-env) 206 ((*motif* 'XtIsManaged) widget)) 207 (let ((py0 (ax-pix 1)) 208 (py1 (ax-pix 3)) 209 (ix0 (ax-inf 0)) 210 (ix1 (ax-inf 2)) 211 (iy0 (ax-inf 1)) 212 (iy1 (ax-inf 3)) 213 (mouse-d 10) 214 (mouse-r 5)) 215 216 (define xe-grfx 217 (let ((px0 (ax-pix 0)) 218 (px1 (ax-pix 2))) 219 (lambda (x) 220 (if (= px0 px1) 221 px0 222 (min px1 223 (max px0 224 (floor (+ px0 (* (- px1 px0) 225 (/ (- x ix0) 226 (- ix1 ix0))))))))))) 227 228 (define (xe-grfy y) 229 (if (= py0 py1) 230 py0 231 (min py0 ; grows downward so y1 < y0 232 (max py1 233 (floor (+ py1 (* (- py0 py1) 234 (/ (- y iy1) 235 (- iy0 iy1))))))))) 236 237 (when (> py0 py1) 238 ((*motif* 'XClearWindow) dpy wn) 239 (draw-axes widget gc name ix0 ix1 iy0 iy1) 240 (do ((lx #f) 241 (ly #f) 242 (len (length cur-env)) 243 (i 0 (+ i 2))) 244 ((= i len)) 245 (let ((cx (xe-grfx (cur-env i))) 246 (cy (xe-grfy (cur-env (+ i 1))))) 247 ((*motif* 'XFillArc) dpy wn gc (- cx mouse-r) (- cy mouse-r) mouse-d mouse-d 0 23040) ; (* 360 64)) 248 (if lx 249 ((*motif* 'XDrawLine) dpy wn gc lx ly cx cy)) 250 (set! lx cx) 251 (set! ly cy)))))))) 252 253