test/pixel-input.sgl

1(import (sigil async)

2 (sigil io)

3 (sigil process)

4 (sigil wm host)

5 (sigil wm model)

6 (sigil wm scene)

7 (sigil wm input)

8 (sigil wm repl)

9 (sigil wm draw))

11(define host (start-host! protocols: 4))

12(define managed #f)

13(define menu #f)

14(define windows '())

15(define output-id #f)

16(define saw-client-move? #f)

17(define saw-client-resize? #f)

20(define button-targets '())

21(set-button-hook! host

22 (lambda (event)

23 (set! button-targets

24 (append button-targets

25 (list (list (input-event-target-kind event) (input-event-target event)))))

26 (drop)))

27(define overlay-box (rect x: 60 y: 80 width: 100 height: 100))

28(define output-box (rect x: 0 y: 0 width: 960 height: 640))

29(define canvas (make-canvas 100 100 1))

30(fill-rect! canvas 0 0 100 100 #x00000000)

31(define overlay (canvas-image canvas))

32(define (show-overlay! input?)

33 (present-pixels! host 500 (text-image-data overlay) 100 100

34 (text-image-stride overlay) overlay-box 1 input?: input?

35 output: output-id bounds: output-box))

37(define (record id)

38 (find (lambda (window) (= (dict-ref window id:) id)) (dict-ref (host-snapshot host) windows:)))

40(define (redraw!)

41 (when (pair? windows)

42 (submit-plan! host

43 (make-scene-plan

44 (map

45 (lambda (id)

46 (let ((override? (dict-ref (record id) override-redirect?:)))

47 (placement window: id

48 box: (if override?

49 (rect x: 700 y: 300 width: 160 height: 100)

50 (rect x: 48 y: 64 width: 480 height: 320))

51 activated?: (not override?))))

52 windows)

53 managed 200))))

55(on-event! host

56 (lambda (event)

57 (let ((id (event-ref event id:)))

58 (case (event-type event)

59 ((ready)

60 (configure-device! host 1 "us" 25 600)

61 (set-seat-capabilities! host 3)

62 (set-pointer-route! host #t))

63 ((output-added)

64 (set! output-id id)

65 (configure-output! host id

66 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: -1

67 width: 960 height: 640 refresh: 60000)))

68 ((output-configured)

69 (display "X_DISPLAY=")

70 (display (host-x-display host))

71 (newline)

72 (flush-output-port))

73 ((window-request)

74 (case (event-ref event request:)

75 ((1) (set! saw-client-move? #t))

76 ((2)

77 (unless (= (event-ref event edges:) 5) (error "client resize edges lost"))

78 (set! saw-client-resize? #t)))

79 (when (= (event-ref event request:) 5)

80 (configure-x11! host id (rect x: 48 y: 64 width: 480 height: 320))))

81 ((window-mapped)

82 (unless (eq? (dict-ref (record id) role:) 'x11)

83 (error "X11 role not copied"))

84 (if (dict-ref (record id) override-redirect?:)

85 (set! menu id)

86 (set! managed id))

87 (set! windows (append windows (list id)))

88 (redraw!))

89 ((window-unmapped window-destroyed)

90 (set! windows (filter (lambda (window) (not (= window id))) windows))

91 (when (eqv? managed id) (set! managed #f))

92 (when (eqv? menu id) (set! menu #f))

93 (redraw!))

94 ((transaction-applied)

95 (display "X11_SCENE=PASS\n")

96 (flush-output-port))))))

98(with-async

99 (let ((repl (start-repl! host (getenv "SIGIL_WM_REPL") (interaction-environment))))

100 (run-host! host)

101 (stop-repl! repl)))

102(unless (and (= (host-statistic host 1) 0) (= (host-statistic host 2) 0))

103 (error "X11 native objects survived teardown"))

104(display "X11_HOST=PASS\n")