diff --git a/scsh/scgame/README b/scsh/scgame/README index 6889e9a..4694634 100644 --- a/scsh/scgame/README +++ b/scsh/scgame/README @@ -1,7 +1,7 @@ scgame is a drawing package a la Carbon. It is based on Xlib for scsh and thus needs scx-0.2. - +You can tune config.scm before you start. Another homebrewed library for the linux framebuffer : diff --git a/scsh/scgame/scgame.scm b/scsh/scgame/scgame.scm index aa71f25..d2c9e41 100644 --- a/scsh/scgame/scgame.scm +++ b/scsh/scgame/scgame.scm @@ -47,7 +47,8 @@ (load "config.scm") (define (display-msg msg) (if SCGAMEDEBUG - (for-each display (list (aspectmsg) " " msg)))) + (for-each display (list (aspectmsg) " " msg)) + (newline))) ;; override for scx-0.2 (define (putpixel x y colorname) @@ -141,7 +142,7 @@ (xputxpm filename)) (define (load-xpm-image-scx filename) - (read-file-to-pixmap win filename '()));;FIXME xpm-attributes == '() + (read-file-to-pixmap win filename #()));;FIXME xpm-attributes == '() (define (load-xpm-image filename) (let ((in (open-input-file filename)) @@ -174,12 +175,12 @@ (define (load-image filename) ;; FIXME read in xpm or png - (display-msg "loading image...") + (display-msg "loading image..") (cond ((string<=? ".xpm" filename) (display-msg "loading xpm suffixed file..") (load-xpm-image-scx filename) ) - (else #f))) + (else (display-msg "no supported image format found")))) (lambda (msg) (cond ((eq? msg 'load-image) load-image) diff --git a/scsh/scgame/scgamewidgets.scm b/scsh/scgame/scgamewidgets.scm index cadd4a0..1e6c5b4 100644 --- a/scsh/scgame/scgamewidgets.scm +++ b/scsh/scgame/scgamewidgets.scm @@ -28,18 +28,107 @@ (load "scgame.scm") -(define (make-scgamewidget) - (lambda (msg) - (display "subclass responsability"))) +;; for inits see scgame.scm -(define (make-button) - (let ((*widget (make-scgamewidget)) - (*image #f)) ;; pixel array +(define (make-scgame-widget) + (define (draw) + (display-msg "subclass responsability")) + + (lambda (msg) + (cond ((eq? msg 'draw) draw) + (else + (display-msg "subclass responsability"))))) + +(define (make-button-widget) + (let ((widget (make-scgame-widget)) + (image #f) ;; pixel array + (pressed-image #f) ;; pixel array + (pressed #f) + (width 0) + (height 0)) (define (set-image filename) - (((make-scimage2)'load-image) filename)) + (set! image (((make-scimage2)'load-image) filename)) + (let ((wh (vector-ref (list->vector image) 1))) + (set! width (car wh)) + (set! height (cadr wh)) + )) + + (define (set-pressed-image filename) + (set! pressed-image (((make-scimage2)'load-image) filename)) + (let ((wh (vector-ref (list->vector image) 1))) + (set! width (car wh)) + (set! height (cadr wh)) + )) + + (define (draw-pressed-image dpy win gc) + (init-sync-x-events dpy) + (map-window dpy win) + (call-with-event-channel + dpy win (event-mask exposure button-press) + (lambda (channel) + (let loop () + (if + (let ((e (receive channel))) + (cond + ((expose-event? e) + (clear-window dpy win) + (draw-points dpy win gc (* width height) 0 0 + (/ width 2) (/ height 2)) + ) + + (else #f))) + (loop)))))) + + (define (draw-image dpy win gc) + (init-sync-x-events dpy) + (map-window dpy win) + (call-with-event-channel + dpy win (event-mask exposure button-press) + (lambda (channel) + (let loop () + (if + (let ((e (receive channel))) + (cond + ((expose-event? e) + (clear-window dpy win) + (draw-points dpy win gc (* width height) 0 0 + (/ width 2) (/ height 2)) + ) + + (else #f))) + (loop)))))) + + (define (draw-points dpy win gc count x y) + (if (zero? (modulo count 100)) + (display-flush dpy)) + (if (not (zero? count)) + (let ((xf (floor (* (+ 1.2 x) width))) ; These lines center the picture + (yf (floor (* (+ 0.5 y) height)))) + (draw-point dpy win gc (inexact->exact xf) (inexact->exact yf)) + (draw-points dpy win gc ;; FIXME1 + (- count 1) + (- (* y (+ 1 (sin (* 0.7 x)))) + (* 1.2 (sqrt (abs x)))) + (- 0.21 x) + width height)))) + + (define (draw) + (if pressed + (draw-image) + (draw-pressed-image)) + (map-window dpy win)) + + (define (press!) + (set! pressed #t)) + + (define (release!) + (set! pressed #f)) (lambda (msg) (cond ((eq? 'set-image) set-image) - (else (aspecterror)(display "make-button")) + ((eq? 'set-pressed-image) set-pressed-image) + ((eq? 'press!) press!) + ((eq? 'release!) release!) + (widget msg) ))))