AtlatestRepositorysigil-wm

sigil-wm / tree / testtransaction-pixels.sgl

1(import (sigil async) (sigil io) (sigil process) (sigil ffi)
2 (sigil wm host) (sigil wm scene) (sigil wm model) (sigil wm session))
3(define windows '())
4(define output #f)
5(define accepted #f)
6(define applied #f)
7(define captured #f)
8(define host #f)
9(define (require condition message . details)
10 (unless condition (apply error message details)))
11(define (await message predicate)
12 (let loop ((attempt 0))
13 (unless (predicate)
14 (require (< attempt 2000) message)
15 (sleep 0.005)
16 (loop (+ attempt 1)))))
17(define (header port)
18 (let loop ((bytes '()))
19 (let ((byte (read-u8 port)))
20 (require (not (eof-object? byte)) "truncated capture header")
21 (if (= byte 10) (list->string (map integer->char (reverse bytes)))
22 (loop (cons byte bytes))))))
23(define (sample)
24 (let ((path (string-append (getenv "XDG_RUNTIME_DIR") "/transaction.ppm")))
25 (set! captured #f)
26 (require (capture-output! host output path) "capture not queued")
27 (await "capture incomplete" (lambda () captured))
28 (call-with-port (open-binary-input-file path)
29 (lambda (port)
30 (require (equal? (header port) "P6") "capture format")
31 (let* ((dimensions (read (open-input-string (string-append "(" (header port) ")"))))
32 (width (car dimensions)) (height (cadr dimensions)))
33 (require (equal? (header port) "255") "capture depth")
34 (let ((pixels (read-bytevector (* 3 width height) port)))
35 (map (lambda (point)
36 (let ((at (* 3 (+ (car point) (* width (cadr point))))))
37 (+ (* 65536 (bytevector-u8-ref pixels at))
38 (* 256 (bytevector-u8-ref pixels (+ at 1)))
39 (bytevector-u8-ref pixels (+ at 2)))))
40 '((100 100) (600 400) (20 20) (5 5)))))))))
41(define (scene second?)
42 (make-scene-plan
43 (list
44 (placement window: (car windows)
45 box: (if second? (rect x: 20 y: 20 width: 600 height: 300)
46 (rect x: 50 y: 40 width: 300 height: 200)))
47 (placement window: (cadr windows) box: (rect x: 500 y: 300 width: 300 height: 200)
48 shown?: (not second?)))
49 0 2000))
50(define (script)
51 (await "two clients missing" (lambda () (= (length windows) 2)))
52 (let ((initial (submit-plan! host (scene #f))))
53 (await "initial scene incomplete" (lambda () (equal? applied initial))))
54 (require (equal? (sample) '(#x00cc44 #xcc2244 0 0)) "initial client pixels")
55 (let ((next (submit-plan! host (scene #t))))
56 (await "new scene not accepted" (lambda () (equal? accepted next)))
57 (require (not (equal? applied next)) "delayed client committed too soon")
58 (require (= (host-statistic host 7) 2) "pending snapshot tree count")
59 (require (equal? (sample) '(#x00cc44 #xcc2244 0 0)) "pending scene displaced saved buffers")
60 (require (not (equal? applied next)) "capture missed the pending scene")
61 (await "new scene incomplete" (lambda () (equal? applied next)))
62 (require (equal? (sample) '(#x00cc44 0 #x00cc44 0)) "completed scene pixels")
63 (require (and (= (host-statistic host 7) 0) (> (host-statistic host 8) 0)) "completed snapshot ownership"))
64 (display "TRANSACTION_SNAPSHOT=PASS nonzero positions pending buffers atomic hide and resize\n")
65 (let ((storage (c-alloc 4)) (bounds (rect x: 0 y: 0 width: 960 height: 640)))
66 (pointer-set! storage ffi/uint32 0 #xffffffff)
67 (require (present-pixels! host 1 storage 1 1 4 (rect x: 5 y: 5 width: 1 height: 1) 1
68 output: output bounds: bounds) "valid scoped pixel refused")
69 (require (= (list-ref (sample) 3) #xffffff) "valid scoped pixel missing")
70 (let ((bytes (host-statistic host 4)) (drops (host-statistic host 6)))
71 (pointer-set! storage ffi/uint32 0 #xffff0000)
72 (require (present-pixels! host 1 storage 1 1 4 (rect x: 5 y: 5 width: 1 height: 1) 1
73 output: output bounds: (rect x: 0 y: 0 width: 961 height: 640)) "stale pixel not queued")
74 (require (present-pixels! host 2 storage 1 1 4 (rect x: 5 y: 5 width: 1 height: 1) 1
75 output: 999999 bounds: bounds) "retired output pixel not queued")
76 (require (not (present-pixels! host 3 storage 1 1 4 (rect x: 960 y: 0 width: 1 height: 1) 1
77 output: output bounds: bounds)) "out-of-scope rectangle accepted")
78 (require (= (list-ref (sample) 3) #xffffff) "stale pixel changed current image")
79 (require (and (= (host-statistic host 4) bytes) (= (host-statistic host 5) 1)
80 (= (host-statistic host 6) (+ drops 2))) "discard retained storage or nodes"))
81 (configure-output! host output
82 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: -1
83 width: 961 height: 640 refresh: 60000))
84 (await "output scope did not change"
85 (lambda () (= (dict-ref (car (dict-ref (host-snapshot host) outputs:)) width:) 961)))
86 (require (= (list-ref (sample) 3) 0) "invalidated pixel remains visible")
87 (let ((token
88 (submit-plan! host
89 (make-scene-plan
90 (append (scene-plan-placements (scene #t))
91 (list (placement window: 1 kind: 'pixel
92 box: (rect x: 5 y: 5 width: 1 height: 1))))
93 0 2000))))
94 (await "pixel scene did not apply" (lambda () (equal? applied token))))
95 (require (= (list-ref (sample) 3) 0) "scene plan revived invalidated scoped pixels")
96 (display "PIXEL_PLAN_SCOPE=PASS stale scoped pixels stay disabled in complete plans\n")
97 (c-free storage)
98 (require (remove-pixels! host 1) "pixel removal not queued")
99 (require (= (list-ref (sample) 3) 0) "removed pixel remains visible")
100 (require (and (= (host-statistic host 4) 0) (= (host-statistic host 5) 0)) "pixel removal retained storage"))
101 (display "PIXEL_SCOPE=PASS stale and retired discard malformed bounds refusal current pixels retained\n")
102 ;; There is deliberately no later restack: even the first captured frame
103 ;; after creation must keep the uploaded decoration below the upper pixel.
104 (let ((storage (c-alloc 4)) (box (rect x: 5 y: 5 width: 1 height: 1)))
105 (pointer-set! storage ffi/uint32 0 #xffffffff)
106 (require (present-pixels! host 500 storage 1 1 4 box 1) "upper pixel refused")
107 (let loop ((index 0))
108 (when (< index 12)
109 (pointer-set! storage ffi/uint32 0 #xffff00ff)
110 (require (present-pixels! host 501 storage 1 1 4 box 1
111 order: '((pixel 501) (pixel 999999) (window 999999) (pixel 500)))
112 "ordered pixel refused")
113 (require (= (list-ref (sample) 3) #xffffff) "new pixel flashed above upper resource")
114 (require (remove-pixels! host 501) "ordered pixel removal refused")
115 (loop (+ index 1))))
116 (require (present-pixels! host 501 storage 1 1 4 box 1
117 order: '((pixel 500) (pixel 501))) "upper insertion refused")
118 (require (= (list-ref (sample) 3) #xff00ff) "upper ordered pixel was not shown")
119 (require (present-pixels! host 501 storage 1 1 4 box 1
120 order: '((pixel 501) (pixel 500))) "existing ordered pixel refused")
121 (require (= (list-ref (sample) 3) #xffffff) "existing ordered update did not move below")
122 (require (not (present-pixels! host 501 storage 1 1 4 box 1
123 order: '((pixel 501) (pixel 500) (pixel 501))))
124 "duplicate order admitted")
125 (require (guard (exception (#t #t))
126 (present-pixels! host 501 storage 1 1 4 box 1 order: '((pixel 500))) #f)
127 "order without uploaded pixel admitted")
128 (require (remove-pixels! host 501) "lower pixel cleanup refused")
129 (require (remove-pixels! host 500) "upper pixel cleanup refused")
130 (sample)
131 (require (and (= (host-statistic host 4) 0) (= (host-statistic host 5) 0))
132 "ordered pixel storage retained")
133 (c-free storage))
134 (display "PIXEL_ORDER=PASS first-frame insertion existing-update retired-neighbours invalid-order cleanup\n")
135 (let ((storage (c-alloc 4))
136 (ids (map (lambda (index) (+ index 10)) (iota 384))))
137 (pointer-set! storage ffi/uint32 0 #xff336699)
138 (for-each
139 (lambda (id)
140 (require
141 (present-pixels! host id storage 1 1 4
142 (rect x: 8 y: 8 width: 1 height: 1) 1)
143 "stress pixel admission failed"))
144 ids)
145 (let* ((placements
146 (append (scene-plan-placements (scene #t))
147 (map (lambda (id)
148 (placement window: id kind: 'pixel
149 box: (rect x: 8 y: 8 width: 1 height: 1)))
150 ids)))
151 (plan (make-scene-plan placements 0 2000))
152 (token (submit-plan! host plan)))
153 (await "decorated scene above old capacity did not apply"
154 (lambda () (equal? applied token)))
155 (require (= (length placements) 386) "stress plan size changed")
156 (require
157 (not (validate-plan
158 (make-scene-plan
159 (map (lambda (id)
160 (placement window: (+ id 1)
161 box: (rect x: 0 y: 0 width: 1 height: 1)))
162 (iota 257))
163 0 2000)))
164 "window budget changed"))
165 (for-each (lambda (id) (remove-pixels! host id)) ids)
166 (c-free storage)
167 (sample)
168 (require (= (host-statistic host 5) 0) "stress pixels retained")
169 (display "PIXEL_PLAN_CAPACITY=PASS 384-pixels 2-windows atomic-plan retained-window-budget clean-removal\n"))
170 (stop-host! host))
171(call-with-host-session
172 (lambda () (start-host!))
173 (lambda (session)
174 (set! host session)
175 (on-event! host
176 (lambda (event)
177 (case (event-type event)
178 ((output-added)
179 (set! output (event-ref event id:))
180 (configure-output! host output
181 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: -1 width: 960 height: 640 refresh: 60000)))
182 ((output-configured)
183 (display "WAYLAND_SOCKET=") (display (host-socket host)) (newline) (flush-output-port))
184 ((window-initial) (configure-window! host (event-ref event id:) 300 200))
185 ((window-mapped)
186 (set! windows (append windows (list (event-ref event id:))))
187 (display "TRANSACTION_MAPPED=") (display (length windows)) (newline) (flush-output-port))
188 ((transaction-accepted) (set! accepted (event-ref event id:)))
189 ((transaction-applied) (set! applied (event-ref event id:)))
190 ((capture-completed) (require (event-ref event success?:) "capture failed") (set! captured #t))
191 ((transaction-rejected command-rejected) (error "unexpected fixture rejection" (event-raw event))))))
192 (with-async (go (run-host! host)) (go (script))))
193 (lambda (session)
194 (require (every (lambda (index) (= (host-statistic session index) 0)) '(1 2 3 4 5 7))
195 "transaction fixture retained storage or rejected commands")))