examples/tabbed.sgl

1(import (sigil ffi) (sigil async) (sigil wm model) (sigil wm scene) (sigil wm draw)

2 (sigil wm host) (sigil wm input) (sigil wm repl) (sigil process) (sigil wm examples support))

4(define (tabbed root box snapshot trigger)

5 (map (lambda (id)

6 (placement window: id shown?: (= id (container-data root))

7 activated?: (= id (container-data root))

8 box: (rect x: (rect-x box) y: (+ (rect-y box) 32)

9 width: (rect-width box) height: (- (rect-height box) 32))))

10 (container-children root)))

12(define font #f)

13(define cache (make-image-cache))

14(define labels '())

15(define (headers host root box snapshot)

16 (unless font (set! font (open-text-font "monospace" "Regular" 12 1)))

17 (for-each

18 (lambda (id)

19 (unless (memv id (container-children root))

20 (when (remove-pixels! host (+ 100000 id)) (remove-cached-image! cache id))))

21 labels)

22 (set! labels (container-children root))

23 (if (null? labels)

24 '()

25 (let ((width (quotient (rect-width box) (length labels))))

26 (map

27 (lambda (id index)

28 (let* ((window (find (lambda (window) (= (dict-ref window id:) id))

29 (dict-ref snapshot windows:)))

30 (color (if (= id (container-data root)) #xffffffff #x888888ff))

31 (title (dict-ref window title:)))

32 (unless (cache-image! cache id (list title width color)

33 (lambda () (render-text font title width 32 color))

34 (lambda (image changed?)

35 (let ((target (rect x: (+ (rect-x box) (* index width)) y: (rect-y box)

36 width: width height: 32)))

37 (if changed?

38 (present-pixels! host (+ 100000 id) (text-image-data image)

39 (text-image-pixel-width image) (text-image-pixel-height image)

40 (text-image-stride image) target 1)

41 (place-pixels! host (+ 100000 id) target)))))

42 (error "title image queue full"))

43 (placement window: (+ 100000 id) kind: 'pixel

44 box: (rect x: (+ (rect-x box) (* index width)) y: (rect-y box) width: width height: 32))))

45 labels (iota (length labels))))))

47(define example (make-example tabbed headers))

48(define host (example-host example))

49(with-async

50 (let ((repl (and (getenv "SIGIL_WM_REPL")

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

52 (run-host! host)

53 (when repl (stop-repl! repl))))

54(clear-image-cache! cache)

55(when font (close-text-font! font))

56(unless (and (= (host-statistic host 1) 0)

57 (= (host-statistic host 2) 0)

58 (= (host-statistic host 4) 0))

59 (error "native objects or copied buffers survived shutdown"))