updated for current interface
This commit is contained in:
frese
parent
6abec7c2a1
commit
2298e207a0
|
|
@ -1,10 +1,6 @@
|
|||
#!/bin/sh
|
||||
|
||||
../../scx <<EOF
|
||||
|
||||
,batch on
|
||||
|
||||
,open srfi-1 signals xlib xft xrender rendezvous-channels threads
|
||||
exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -o srfi-1 -o signals -o xft -o xrender -s "$0" "$@"
|
||||
!#
|
||||
|
||||
(define *font-size* 36.0)
|
||||
|
||||
|
|
@ -114,7 +110,3 @@
|
|||
(close-display dpy))))
|
||||
|
||||
(font-demo)
|
||||
|
||||
,exit
|
||||
|
||||
EOF
|
||||
|
|
|
|||
|
|
@ -1,10 +1,6 @@
|
|||
#!/bin/sh
|
||||
|
||||
../../scx <<EOF
|
||||
|
||||
,batch on
|
||||
|
||||
,open xlib rendezvous-channels threads
|
||||
exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -s "$0" "$@"
|
||||
!#
|
||||
|
||||
(define (hello text)
|
||||
(let* ((dpy (open-display))
|
||||
|
|
@ -65,7 +61,3 @@
|
|||
(close-display dpy))))
|
||||
|
||||
(hello "Hello World!")
|
||||
|
||||
,exit
|
||||
|
||||
EOF
|
||||
|
|
|
|||
|
|
@ -1,10 +1,6 @@
|
|||
#!/bin/sh
|
||||
|
||||
../../scx <<EOF
|
||||
|
||||
,batch on
|
||||
,open xlib
|
||||
,batch off
|
||||
exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -s "$0" "$@"
|
||||
!#
|
||||
|
||||
(define (picture point-count)
|
||||
(let* ((dpy (open-display))
|
||||
|
|
@ -12,43 +8,43 @@
|
|||
(height 400)
|
||||
(black (black-pixel dpy))
|
||||
(white (white-pixel dpy))
|
||||
(root (display-root-window dpy))
|
||||
(win (create-window root width height
|
||||
'background-pixel white
|
||||
'event-mask '(exposure button-press)))
|
||||
(gc (create-gcontext win
|
||||
'background white 'foreground black)))
|
||||
(map-window win)
|
||||
(let event-loop ()
|
||||
(let ((e (next-event dpy)))
|
||||
(if
|
||||
(case (event-type e)
|
||||
((expose) (begin
|
||||
(clear-window win)
|
||||
(draw-points win gc point-count 0 0
|
||||
(/ width 2) (/ height 2))
|
||||
(draw-poly-text win gc 10 10 "Click a button to exit"
|
||||
'1-byte)
|
||||
#f))
|
||||
(else #t))
|
||||
#t
|
||||
(event-loop))))
|
||||
(root (default-root-window dpy))
|
||||
(win (create-simple-window dpy root 0 0 width height 1 black white))
|
||||
(gc (create-gc dpy win
|
||||
(make-gc-value-alist (background white)
|
||||
(foreground black)))))
|
||||
(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 point-count 0 0
|
||||
(/ width 2) (/ height 2))
|
||||
(draw-image-string dpy win gc 10 10 "Click a button to exit"))
|
||||
|
||||
(else #f)))
|
||||
(loop)))))
|
||||
(close-display dpy)))
|
||||
|
||||
(define (draw-points win gc count x y hw hh)
|
||||
(define (draw-points dpy win gc count x y hw hh)
|
||||
(if (zero? (modulo count 100))
|
||||
(display-flush-output (window-display win)))
|
||||
(display-flush dpy))
|
||||
(if (not (zero? count))
|
||||
(let ((xf (floor (* (+ 1.2 x) hw ))) ; These lines center the picture
|
||||
(yf (floor (* (+ 0.5 y) hh ))))
|
||||
(draw-point win gc (cons (inexact->exact xf) (inexact->exact yf)))
|
||||
(draw-points win gc (- count 1)
|
||||
(- (* y (+ 1 (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
|
||||
(draw-point dpy win gc (inexact->exact xf) (inexact->exact yf))
|
||||
(draw-points dpy win gc
|
||||
(- count 1)
|
||||
(- (* y (+ 1 (sin (* 0.7 x))))
|
||||
(* 1.2 (sqrt (abs x))))
|
||||
(- 0.21 x)
|
||||
hw hh))))
|
||||
|
||||
(picture 1000)
|
||||
|
||||
,exit
|
||||
y
|
||||
EOF
|
||||
|
|
|
|||
|
|
@ -1,73 +1,68 @@
|
|||
../../scx <<EOF
|
||||
|
||||
,batch on
|
||||
,open xlib
|
||||
,batch off
|
||||
#!/bin/sh
|
||||
exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -s "$0" "$@"
|
||||
!#
|
||||
|
||||
(define (regions)
|
||||
(let* ((dpy (open-display))
|
||||
(cm (display-default-colormap dpy))
|
||||
(black (black-pixel dpy))
|
||||
(white (white-pixel dpy))
|
||||
(blue (alloc-named-color cm 'blue))
|
||||
(win (create-window (display-root-window dpy) 500 500
|
||||
'event-mask '(button-press exposure)
|
||||
'background-pixel white))
|
||||
(gc (create-gcontext win
|
||||
'background white
|
||||
'foreground black))
|
||||
|
||||
(rectangles '((10 20 60 60) (50 100 30 30)))
|
||||
(colors (list black blue))
|
||||
(regions-alist
|
||||
(list (cons (union-rectangle-with-region (car rectangles)
|
||||
(create-region))
|
||||
"black rectangle")
|
||||
(cons (union-rectangle-with-region (cadr rectangles)
|
||||
(create-region))
|
||||
"blue rectangle")))
|
||||
(cm (screen:default-colormap (display:default-screen dpy)))
|
||||
(black (black-pixel dpy))
|
||||
(white (white-pixel dpy))
|
||||
(blue (color:pixel (alloc-named-color dpy cm "blue")))
|
||||
(win (create-simple-window dpy (default-root-window dpy)
|
||||
0 0 500 500 1
|
||||
black white))
|
||||
(gc (create-gc dpy win
|
||||
(make-gc-value-alist
|
||||
(background white)
|
||||
(foreground black))))
|
||||
|
||||
(rectangles (list (make-rectangle 10 20 60 60)
|
||||
(make-rectangle 50 100 30 30)))
|
||||
(colors (list black blue))
|
||||
(regions-alist
|
||||
(map (lambda (rect text)
|
||||
(cons (union-rect-with-region (rectangle:x rect)
|
||||
(rectangle:y rect)
|
||||
(rectangle:width rect)
|
||||
(rectangle:height rect)
|
||||
(create-region))
|
||||
text))
|
||||
rectangles
|
||||
'("black rectangle" "blue rectangle"))))
|
||||
|
||||
(handle-event
|
||||
(lambda (e)
|
||||
(let ((args (event-args e))
|
||||
(type (event-type e)))
|
||||
(case type
|
||||
;; Zeichnen...
|
||||
((expose) (begin
|
||||
(for-each (lambda (rect color)
|
||||
(set-gcontext-foreground! gc color)
|
||||
(fill-rectangle win gc rect))
|
||||
rectangles colors)
|
||||
#t))
|
||||
;; Hit-Tests
|
||||
((button-press)
|
||||
(let* ((x (cdr (assq 'x args)))
|
||||
(y (cdr (assq 'y args)))
|
||||
(rs (filter (lambda (r-n)
|
||||
(point-in-region? (car r-n)
|
||||
x y))
|
||||
regions-alist)))
|
||||
(for-each (lambda (region-name)
|
||||
(display "You clicked: ")
|
||||
(display (cdr region-name))
|
||||
(newline))
|
||||
rs)
|
||||
;; break if none was hit.
|
||||
(not (null? rs))))
|
||||
)))))
|
||||
(map-window dpy win)
|
||||
(init-sync-x-events dpy)
|
||||
|
||||
(map-window win)
|
||||
(let loop ()
|
||||
(display-flush-output dpy)
|
||||
(let ((e (next-event dpy)))
|
||||
(if (handle-event e)
|
||||
(loop)
|
||||
(close-display dpy))))))
|
||||
(call-with-event-channel
|
||||
dpy win (event-mask exposure button-press structure-notify)
|
||||
(lambda (channel)
|
||||
(let loop ()
|
||||
(let ((e (receive channel)))
|
||||
(cond
|
||||
;; Zeichnen...
|
||||
((expose-event? e)
|
||||
(for-each (lambda (rect color)
|
||||
(set-gc-foreground! dpy gc color)
|
||||
(fill-rectangles dpy win gc (list rect)))
|
||||
rectangles colors))
|
||||
;; Hit-Tests
|
||||
((button-event? e)
|
||||
(let* ((x (button-event-x e))
|
||||
(y (button-event-y e))
|
||||
(rs (filter (lambda (r-n)
|
||||
(point-in-region? (car r-n)
|
||||
x y))
|
||||
regions-alist)))
|
||||
(for-each (lambda (region-name)
|
||||
(display "You clicked: ")
|
||||
(display (cdr region-name))
|
||||
(newline))
|
||||
rs)
|
||||
;; break if none was hit.
|
||||
(if (null? rs)
|
||||
(begin
|
||||
(close-display dpy)
|
||||
(exit)))))))
|
||||
(loop))))))
|
||||
|
||||
(regions)
|
||||
|
||||
|
||||
|
||||
,exit
|
||||
y
|
||||
EOF
|
||||
|
|
|
|||
|
|
@ -1,33 +1,35 @@
|
|||
#!/bin/sh
|
||||
exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -s "$0" "$@"
|
||||
!#
|
||||
|
||||
../../scx <<EOF
|
||||
|
||||
,batch on
|
||||
,open xlib
|
||||
,batch off
|
||||
(define all-events-mask
|
||||
(event-mask
|
||||
key-press key-release button-press button-release enter-window leave-window
|
||||
pointer-motion pointer-motion-hint button-1-motion button-2-motion
|
||||
button-3-motion button-4-motion button-5-motion button-motion keymap-state
|
||||
exposure visibility-change structure-notify resize-redirect
|
||||
substructure-notify substructure-redirect focus-change property-change
|
||||
colormap-change owner-grab-button))
|
||||
|
||||
(define (scxev)
|
||||
(let* ((dpy (open-display))
|
||||
(black (black-pixel dpy))
|
||||
(white (white-pixel dpy))
|
||||
(win (create-window (display-default-root-window dpy)
|
||||
300 200
|
||||
'event-mask '(all-events)
|
||||
'background-pixel white))
|
||||
)
|
||||
(set-wm-name! win '("scx Event Listener"))
|
||||
(map-window win)
|
||||
(let event-loop ()
|
||||
(display-flush-output dpy)
|
||||
(let ((e (wait-event dpy)))
|
||||
(display (event-type e)) (display " Event, Data:\n")
|
||||
(display (event-args e)) (newline) (newline)
|
||||
|
||||
(event-loop))
|
||||
(close-display dpy))))
|
||||
(win (create-simple-window dpy (default-root-window dpy) 0 0
|
||||
300 200 0 black white)))
|
||||
|
||||
(set-wm-name! dpy win (string-list->property '("scx Event Listener")))
|
||||
(map-window dpy win)
|
||||
|
||||
(init-sync-x-events dpy)
|
||||
(call-with-event-channel
|
||||
dpy win all-events-mask
|
||||
(lambda (channel)
|
||||
(let loop ()
|
||||
(let ((e (receive channel)))
|
||||
(display (any-event-type e)) (display " on window ")
|
||||
(display (any-event-window e)) (newline)
|
||||
(if (not (destroy-window-event? e))
|
||||
(loop))))))))
|
||||
|
||||
(scxev)
|
||||
|
||||
,exit
|
||||
y
|
||||
EOF
|
||||
Loading…
Reference in New Issue